Repository: fsharp/emacs-fsharp-mode Branch: master Commit: 5212c9359180 Files: 54 Total size: 318.6 KB Directory structure: gitextract__62fiqaz/ ├── .dir-locals.el ├── .github/ │ ├── pull_request_template.md │ └── workflows/ │ └── test.yml ├── .gitignore ├── CHANGELOG.md ├── Eldev ├── ISSUE_TEMPLATE.md ├── LICENSE ├── README.org ├── eglot-fsharp.el ├── fsharp-mode-font.el ├── fsharp-mode-structure.el ├── fsharp-mode-util.el ├── fsharp-mode.el ├── inf-fsharp-mode.el └── test/ ├── CompileCommandData/ │ ├── Directory With Spaces/ │ │ ├── noproj/ │ │ │ └── test.fs │ │ └── proj/ │ │ ├── test.fs │ │ └── test.fsproj │ ├── noproj/ │ │ └── test.fs │ └── proj/ │ ├── Makefile │ ├── test.fs │ └── test.fsproj ├── FindSlnData/ │ ├── bar.sln │ ├── noproj/ │ │ └── test.fs │ ├── sln/ │ │ └── foo.sln │ └── test.fsproj ├── StructureTest/ │ ├── Blocks.fs │ ├── BracketIndent.fs │ ├── ContinuationLines.fs │ ├── Literals.fs │ ├── Nesting.fs │ └── Relative.fs ├── Test1/ │ ├── Error.fs │ ├── FileTwo.fs │ ├── NoProject.fs │ ├── Pervasive.fs │ ├── Program.fs │ ├── Script.fsx │ └── Test1.fsproj ├── Test2/ │ ├── Main.fs │ └── Test2.fsproj ├── apps/ │ ├── FQuake3/ │ │ ├── NativeMappings.fs │ │ └── NativeMappings.fs.faceup │ ├── FSharp.Compatibility/ │ │ ├── Format.fs │ │ └── Format.fs.faceup │ └── RecordHighlighting/ │ ├── Test.fsx │ └── Test.fsx.faceup ├── eglot-fsharp-integration-util.el ├── expression.fsx ├── fsharp-mode-font-tests.el ├── fsharp-mode-structure-tests.el ├── fsi-tests.el ├── integration-tests.el └── nuget.fsx ================================================ FILE CONTENTS ================================================ ================================================ FILE: .dir-locals.el ================================================ ;;; Directory Local Variables ;;; For more information see (info "(emacs) Directory Variables") ((emacs-lisp-mode . ((indent-tabs-mode . nil) (fill-column . 120)))) ================================================ FILE: .github/pull_request_template.md ================================================ ## Description ## How to test ## Related issues ================================================ FILE: .github/workflows/test.yml ================================================ name: "CI" on: pull_request: push: branches: - master jobs: gnu-build: strategy: fail-fast: false matrix: os: [ubuntu-latest, macos-latest] dotnet: [9.0.x] emacs_version: - 28.2 - 29.4 - 30.2 - snapshot runs-on: ${{ matrix.os }} steps: - uses: actions/checkout@v4 - uses: actions/setup-dotnet@v4 with: dotnet-version: ${{ matrix.dotnet }} - uses: purcell/setup-emacs@master with: version: ${{ matrix.emacs_version }} - name: Install Eldev run: curl -fsSL https://raw.github.com/doublep/eldev/master/webinstall/github-eldev | sh - name: Show dotnet sdks run: dotnet --list-sdks - name: Show dotnet version run: dotnet --info - name: Eldev archives run: | echo "Archives:" eldev archives - name: Eldev dependencies run: | echo "Dependencies:" eldev -v dependencies - name: Test run: | echo "Testing:" eldev -dtT test windows-build: runs-on: windows-latest strategy: fail-fast: false steps: - uses: actions/checkout@v4 - uses: actions/setup-dotnet@v4 with: dotnet-version: 9.0.x - name: Show dotnet sdks run: dotnet --list-sdks - name: Show dotnet version run: dotnet --info - name: Set up Emacs on Windows uses: jcs090218/setup-emacs-windows@master with: version: 29.4 - name: Install Eldev run: curl.exe -fsSL https://raw.github.com/doublep/eldev/master/webinstall/eldev.bat | cmd /Q - name: Eldev archives run: | echo "Archives:" ~/.local/bin/eldev.bat archives - name: Eldev dependencies run: | echo "Dependencies:" ~/.local/bin/eldev.bat dependencies - name: Test run: | echo "Testing:" ~/.local/bin/eldev.bat -p -dtT test ================================================ FILE: .gitignore ================================================ *.elc bin tmp *~ # Useful for doing releases emacs-fsharp-mode-bin/ # Dependency archive fsautocomplete-*.zip # Development obj/ .ionide/ ================================================ FILE: CHANGELOG.md ================================================ ## 1.10 (2019.12-01) Features: - #210: Remove old FsAutoComplete support (use LSP) - provide eglot (Emacs LSP client) integration and add eglot integration tests (using Emacs buttercup) - Use Cask instead to automate the package development cycle; development, dependencies, testing, building, packaging - Make project.el aware of F# projects - Use Emacs org-mode for README Bugfixes: - #68: Indentation Cleanup / SMIE mode not being applied properly (Gastove) ## 1.9.14 (2019-06-09) Features: - #207: Update to FsAutoComplete 0.38.1 - #206: Set default build command to msbuild if found Bugfixes: - #198: Use buffer-local version of company-quickhelp-mode ## 1.9.13 (2018) Features: - #193: Update to FSAC 0.36 - Fixes #183: Load .Net Core projects that reference other projects - Fixes #182: .fs files not parsed Bugfixes: - #190: Fix attribute locking, improve imenu support - #189: Fix bug in font locking for active patterns - #187: Fix Infinite loop when file begins with a comment preceded by whitespace - #180: Use scoop instead of Chocolatey package for Appveyor testing - #179: Use portable (Windows support) Makefile - #176: Add F# Tools 10.1 SDK directory to search dirs - #175: Paths with characters outside ASCII gives error FS2302 (Windows) - #171: Fix for phrase detection for if/then/else constructs ## 1.9.12 (2018-05-18) Features: - #170: Flycheck verify (Improved fsautocomplete diagnostics) Bugfixes: - #167: Fix error when visiting a new F# script file and fsautocomplete is not started - #168: Add Flycheck predicate function to prevent error when fsautocomplete is not running - #162: Stop matching [ as part of normal residue - #157: Don't change global value of `comment-indent-function' - #153: Add access control keywords to declaration regexes ## 1.9.11 (2017-10-21) Features: - #151: Correctly find MSBuild from VS2017 Bugfixes: - #152: Handle failure to find build commands gracefully ## 1.9.10 (2017-09-18) Bugfixes: - #146: Understand FSAC 0.34 error msgs ## 1.9.9 (2017-09-15) Features - #143: Update to FsAutoComplete 0.34.0 Bugfixes: - #139: Disable flycheck and fsharp-doc-mode when fsharp-ac-intellisense-enabled is nil ## 1.9.8 (2017-06-17) Features: - #134: Improved logging - #137: fsharp-shift-region-[left,right]: change bindings to 'C-c <' and 'C-c >' Bugfixes: - #136: Use correct F# interactive prompt regex ## 1.9.7 (2017-06-06) Bugfixes: - #131: Don't panic on malformed JSON (debug messages) - #133: Update faceup to capture font-locking <| ## 1.9.6 (2017-04-16) Features: - #127: Update to FsAutoComplete 0.32.0 (.NET Core project support) Bugfixes: - #125: Small fixes to try to prevent fsharp-mode to freeze all emacs - #122: Make fsharp-doc-mode hook buffer-local ## 1.9.5 (2017-01-21) Bugfixes: - #117: Fix `type` locking - #118: Don't change company-idle-delay - #120: Fix FSAC hanging issue ## 1.9.4 (2016-11-30) Features - #116: Improve Active Pattern font locking, eval-when-compile the main font-lock-keywords form - #114: Clean up font-locking code ## 1.9.3 (2016-10-31) Features - #111: Update to FsAutoComplete 0.32.0 - #109: Define inferior-fsharp-mode as variant of comint mode Bugfixes: - #110: Dont change default indent region function - #105: Don't send trailing newline to fsautocomplete - #104: Dont change `company-minimum-prefix-length' ## 1.9.2 (2016-09-30) Features - #98: Enable imenu support ## 1.9.1 (2016-07-19) Features: - Update to FsAutoComplete 0.29.0. ## 1.9.0 (2016-07-09) Features: - #71: fontify the doc string (@nosami). - #77: Use new typesig command for fsharp-doc mode (@rneatherway). - #88: Use flycheck for error reporting (@juergenhoetzel). Bugfixes: - #75: Do not change current buffer when starting FSI (@rneatherway). - #76: Record type highlighting (@rneatherway). - #79: Overlays should not grow when typing (@rneatherway). - #82: Inferior fsi: #silentcd to local directory in Tramp (@juergenhoetzel). - #83: Fix completion of type annotated symbols (@juergenhoetzel). - #85: Don't modify company-transformers (@nosami). - #86: Don't clobber company-backends (@nosami). ## 1.8.1 (2016-04-14) Features: - #66: Tramp support (@juergenhoetzel). - #69: Prefer exact case sort in completion list (@nosami). ## 1.8.0 (2016-04-05) Features: - Update to FsAutoComplete 0.28.0 to support #65. - #65: Faster completions (thanks to @nosami). - #56: Use FsAutoComplete "startswith" filter (thanks to @juergenhoetzel). Bugfixes: - #67: Fix use of popup (thanks to @drvink) - #60: Unbreak company support on non-graphic displays (thanks to @drvink) - #58: Handle buffers not visiting a file (thanks to @juergenhoetzel). ## 1.7.4 (2016-02-05) Features: - #49: Use company for completions (thanks to @nosami). Bugfixes: - Update to FsAutoComplete 0.27.2, fixes project cracking for files with spaces in the path. ## 1.7.3 (2016-01-26) Bugfixes: - Update to FsAutoComplete 0.27.1, fixes Windows VS2015-only support. ## 1.7.2 (2016-01-08) Bugfixes: - #50: Inhibit electric-indent for fsharp-mode buffers (thanks to @joranvar). ## 1.7.1 (2015-11-24) Features: - #45: Update FSAC to 0.27, enable project cracking logs. ## 1.7.0 (2015-11-24) Features: - #34: Switch to SMIE-based indentation engine (thanks to m00nlight). - #31: Add highlighting of other usages of symbol at point. ## 1.6.3 (2015-10-24) Bugfixes: - Update to FsAutoComplete 0.26.1, which fixes Windows support. ## 1.6.2 (2015-10-20) Bugfixes: - Update to FsAutoComplete 0.26.0. - #30: Allow use of symbols containing '%' - #28: Fix FSI usage in buffers whose name differs from filename - #27: Fix test of fsharp-ac-debug ## 1.6.1 (2015-09-02) Bugfixes: - Update to FsAutoComplete 0.23.1. Fixed MSBuild v14 on non-English systems. ## 1.6.0 (2015-09-01) Features: - Update to FSharp.AutoComplete 0.23.0. Contains many improvements, which can be found in the changelog at https://github.com/fsharp/FsAutoComplete/releases - #20: Add C-x C-e as default keybinding for eval. - #22: Allow .fsx files to be compiled as well. Bugfixes: - #16: Remove BOM from process output. ## 1.5.4 (2015-06-04) Features: - #4: Update to FSharp.AutoComplete 0.18.0. All unsaved buffer contents (not just the current buffer) will now be used for type checking. Bugfixes: - #9: Correct quoting of path to fsi.exe on Windows. ## 1.5.3 (2015-05-26) Note that in since 1.5.2 fsharp-mode has been migrated from https://github.com/fsharp/fsharpbinding to a [separate repository](https://github.com/fsharp/emacs-fsharp-mode). The issue number `#2` below, and all future issue numbers, refer to the new repository. Features: - #993: Push the mark before going to definition (using etags) Bugfixes: - #1005: Fix issue with compile-command quoting - #2: Add `do!` as a keyword. ## 1.5.2 (2015-03-20) Bugfixes: - #973: Force comint-process-echoes to nil to avoid hangs ## 1.5.1 (2015-01-14) Bugfixes: - #923: Autocompletion not working on Emacs 24.4+ on Windows ## 1.5.0 (2014-11-25) Incorporate FSharp.AutoComplete version 0.13.3, which has corrected help text for the parse command and uses FCS 0.0.81. Features: - #235: Support multiple projects simultaneously Bugfixes: - #824: Emacs should give a better error message if fsautocomplete not found - #808: C-c C-p gives an error if no project file above current file's directory - #790: Can't make fsac requests in indirect buffers - #754: Compiler warnings when installing fsharp-mode from MELPA ## 1.4.2 (2014-10-30) Incorporate FSharp.AutoComplete version 0.13.2, which returns more information if the project parsing fails. Features: - #811: Return exception message on project parsing fail ## 1.4.1 (2014-10-30) Incorporate FSharp.AutoComplete version 0.13.1, which contains a fix for goto definition. Bugfixes: - #787: Correct off-by-one error in fsac goto definition ## 1.4.0 (2014-10-26) The main feature of this release is that the project parsing logic has been moved to FSharp.Compiler.Service as part of fixing #728. Features: - #319: Better error feedback when no completion data available - #720: Rationalise emacs testing, also fixed #453 Bugfixes: - #765: Do not offer completions in irrelevant locations (strings/comments) - #721: Tests for Emacs syntax highlighting, and resultant fixes - #248: Run executable file now uses output from FSharp.AutoComplete - #728: Fix project support on Windows ## 1.3.0 (2014-08-28) Changes by @rneatherway unless otherwise noted. Major changes in this release are performance improvements thanks to @juergenhoetzel (avoiding parsing the current buffer unless necessary), and fixes for syntax highlighting. Features: - #481: Only parse the current buffer if it is was modified (@juergenhoetzel) Bugfixes: - #619: Disable FSI syntax highlighting - #670: Prevent double dots appearing during completion - #485: Fetch SSL certs before building exe in emacs dir - #496: Corrections to emacs syntax highlighting - #597: Highlight preprocessor and async - #605: Add FSI directives to syntax highlighting of emacs - #571: Correct range-check for emacs support - #572: Ensure fsi prompt is readonly - #452: Fetch SSL certs before building exe in emacs dir ================================================ FILE: Eldev ================================================ ; -*- mode: emacs-lisp; lexical-binding: t -*- (setq package-lint-main-file "eglot-fsharp.el") (setq eldev-project-main-file "eglot-fsharp.el") (eldev-use-package-archive 'melpa-unstable) (eldev-use-package-archive 'gnu) (eldev-use-plugin 'autoloads) (setq package-archive-priorities '(("melpa-unstable" . 400) ("gnu" . 300))) ================================================ FILE: ISSUE_TEMPLATE.md ================================================ ### Description Please provide a succinct description of your issue. ### Repro steps Please provide the steps required to reproduce the problem 1. Step A 2. Step B ### Expected behavior Please provide a description of the behaviour you expect. ### Actual behavior Please provide a description of the actual behaviour you observe. ### Known workarounds Please provide a description of any known workarounds. ### Related information * Operating system * Branch * Emacs version * .NET Runtime, CoreCLR or Mono Version * Performance information, links to performance testing scripts ================================================ FILE: LICENSE ================================================ Apache License Version 2.0, January 2004 http://www.apache.org/licenses/ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 1. Definitions. "License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. "Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. "Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. "You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. "Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. "Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. "Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). "Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. "Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." "Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. 2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. 3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. 4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: (a) You must give any other recipients of the Work or Derivative Works a copy of this License; and (b) You must cause any modified files to carry prominent notices stating that You changed the files; and (c) You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and (d) If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. 5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. 6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. 7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. 8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. 9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. END OF TERMS AND CONDITIONS APPENDIX: How to apply the Apache License to your work. To apply the Apache License to your work, attach the following boilerplate notice, with the fields enclosed by brackets "[]" replaced with your own identifying information. (Don't include the brackets!) The text should be enclosed in the appropriate comment syntax for the file format. We also recommend that a file or class name and description of purpose be included on the same "printed page" as the copyright notice for easier identification within third-party archives. Copyright [yyyy] [name of copyright owner] Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. ================================================ FILE: README.org ================================================ [[http://melpa.org/#/fsharp-mode][file:http://melpa.org/packages/fsharp-mode-badge.svg]] [[https://stable.melpa.org/#/fsharp-mode][file:https://stable.melpa.org/packages/fsharp-mode-badge.svg]] [[https://github.com/fsharp/emacs-fsharp-mode/actions][file:https://github.com/fsharp/emacs-fsharp-mode/workflows/CI/badge.svg]] * fsharp-mode Provides support for the F# language in Emacs. Includes the following features: - Syntax highlighting and indentation - Support for F# Interactive - Via [[https://github.com/joaotavora/eglot/issues][Eglot]] LSP-client integration: - Displays type signatures and tooltips - Flymake - Completion - Jump to definition [[https://www.gnu.org/software/emacs/manual/html_node/emacs/Xref.html][Find Identifier References]] (Xref) ** Project Status This implementation is based on a very old OCaml-mode codebase and has become increasingly difficult to maintain. Future development efforts should focus on [[https://github.com/bbatsov/fsharp-ts-mode][fsharp-ts-mode · GitHub]] which is built on modern Emacs features, leveraging Tree-Sitter support. ** LSP mode The current version of =fsharp-mode= installs =fsautocomplete.exe= automatically via =eglot-fsharp.el= (part of this mono repo, [[https://melpa.org/#/eglot-fsharp][eglot-fsharp on melpa]]) or [[https://github.com/emacs-lsp/lsp-mode][lsp-mode]] (untested). =fsharp-mode= is tested with Emacs 27.1+ and NET Core 6 (LTS) ** Installation *** Package =fsharp-mode= is available on [[https://melpa.org][MELPA]] and can be installed using the built-in package manager. If you're not already using MELPA, add the following to your init.el: #+BEGIN_SRC elisp ;;; Initialize MELPA (require 'package) (add-to-list 'package-archives '("melpa" . "http://melpa.org/packages/")) (unless package-archive-contents (package-refresh-contents)) (package-initialize) ;;; Install fsharp-mode (unless (package-installed-p 'fsharp-mode) (package-install 'fsharp-mode)) (require 'fsharp-mode) #+END_SRC If you are a user of [[https://github.com/jwiegley/use-package][use-package]] you can instead do #+BEGIN_SRC elisp (use-package fsharp-mode :defer t :ensure t) #+END_SRC *** From source I recommend to use [[https://cask.github.io/why-cask.html][Cask]]. Add this to your =Cask= file: #+BEGIN_SRC elisp (depends-on "fsharp-mode" :git "https://github.com/fsharp/emacs-fsharp-mode.git") #+END_SRC ** Eglot integration The =eglot-fsharp= integration is not part of [[https://melpa.org/#/fsharp-mode][fsharp-mode on melpa]]. It is available via the seperate package [[https://melpa.org/#/eglot-fsharp][eglot-fsharp on melpa]]. Add to your config: #+BEGIN_SRC elisp (require 'eglot-fsharp) #+END_SRC and execute =M-x eglot= With eglot running use `xref-find-definitions` (bound to =M-.= pr. default) to go to definition. Completions are accessable via. `completion-at-point` (or a completion backend ex. company-mode [[https://melpa.org/#/company]]) ** Projects =fsharp-mode= has support for Emacs build-in project management via =project.el= ** Configuration *** Compiler and REPL paths The F# compiler and interpreter should be set to good defaults for your OS as long as the relevant executables can be found on your PATH or in other standard locations. If you have a non-standard setup you may need to configure these paths manually. On Windows: #+BEGIN_SRC elisp (setq inferior-fsharp-program "c:\\Path\\To\\Fsi.exe") #+END_SRC On Unix-like systems, you must use the *--readline-* flag to ensure F# Interactive will work correctly with Emacs. Typically =fsi= and =fsc= are invoked through the shell scripts =fsharpi= and =fsharpc=: #+BEGIN_SRC elisp (setq inferior-fsharp-program "path/to/fsharpi --readline-") #+END_SRC *** Key Bindings If you are new to Emacs, you might want to use the menu (call =menu-bar-mode= if you don't see it). However, it's usually faster to learn a few useful bindings: | Key binding | Description | |------------------+-------------------------------------------| | =C-c C-r= | Evaluate region | | =C-c C-f= | Load current buffer into toplevel | | =C-c C-e= | Evaluate current toplevel phrase | | =C-M-x= | Evaluate current toplevel phrase | | =C-M-h= | Mark current toplevel phrase | | =C-c C-s= | Show interactive buffer | | =C-c C-c= | Compile with fsc | | =C-c x= | Run the executable | | =C-c C-a= | Open alternate file (.fsi or .fs) | | =C-c l= | Shift region to left | | =C-c r= | Shift region to right | | =C-c = | Move cursor to the beginning of the block | | =C-c C-d=, =M-.= | Jump to definition of symbol at point | | =C-c C-b=, =M-,= | Return to where point was before jump. | To interrupt the interactive mode, use =C-c C-c=. This is useful if your code does an infinite loop or a very long computation. If you want to shift the region by 2 spaces, use: =M-2 C-c r= In the interactive buffer, use ==M-RET= to send the code without explicitly adding the =;;= thing. ** Editor In order to change tab size it is possible to put this in emacs profile: #+BEGIN_SRC elisp (setq-default fsharp-indent-offset 2) #+END_SRC Because the F# language is sensitive to indentation, you might wan't to highlight indentation: #+BEGIN_SRC elisp (add-hook 'fsharp-mode-hook 'highlight-indentation-mode) #+END_SRC ** Troubleshooting =fsharp-mode= is still under development, so you may encounter some issues. Please report them so we can improve things! Open an issue on [[https://github.com/fsharp/emacs-fsharp-mode/][Github]]. *** No autocompletion in FSX files The root cause is documented in this Ionide issue: [[https://github.com/ionide/ionide-vscode-fsharp/issues/1244][4.2.0 - No auto complete or typechecking in FSX files]] As a workaround can add a reference to the facade netstandard assembly (path is platform/SDK-dependent). On Arch Linux using [[https://aur.archlinux.org/packages/dotnet-sdk-lts-bin][dotnet sdk lts]] add this to your =fsx= file: #+BEGIN_SRC fsharp #r "/opt/dotnet/sdk/2.1.801/ref/netstandard.dll" #+END_SRC *** Project file issues If your project file does not seem to be being parsed correctly, so that you have missing references or other incorrect intellisense results, it is possible to obtain a detailed log of LSP events in this buffers: - =*EGLOT (PROJECT/fsharp-mode) stderr*= - =*EGLOT (PROJECT/fsharp-mode) output*= - =*EGLOT (PROJECT/fsharp-mode) events*= ** Contributing This project is maintained by the [[http://fsharp.org/][F# Software Foundation]], with the repository hosted on [[https://github.com/fsharp/emacs-fsharp-mode][GitHub]]. Pull requests are welcome. Please run the test-suite with [[https://doublep.github.io/eldev/][Eldev]] =eldev -dtT test= before submitting a pull request. *** Maintainers The maintainers of this repository appointed by the F# Core Engineering Group are: - [[https://github.com/juergenhoetzel][Jürgen Hötzel]], [[http://github.com/forki][Steffen Forkmann]], [[http://github.com/kjnilsson][Karl Nilsson]] and [[http://github.com/guillermooo][Guillermo López-Anglada]] - The primary maintainer for this repository is [[https://github.com/juergenhoetzel][Jürgen Hötzel]] Previous maintainers: - [[https://github.com/rneatherway][Robin Neatherway]] ================================================ FILE: eglot-fsharp.el ================================================ ;;; eglot-fsharp.el --- fsharp-mode eglot integration -*- lexical-binding: t; -*- ;; Copyright (C) 2019-2024 Jürgen Hötzel ;; Author: Jürgen Hötzel ;; Package-Requires: ((emacs "27.1") (eglot "1.4") (fsharp-mode "1.10") (jsonrpc "1.0.14")) ;; Version: 1.10 ;; Keywords: languages ;; URL: https://github.com/fsharp/emacs-fsharp-mode ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . ;;; Commentary: ;; Lua eglot introduced ;;; Code: (require 'eglot) (require 'fsharp-mode) (require 'gnutls) (defgroup eglot-fsharp nil "LSP support for the F# Programming Language, using F# compiler service." :link '(url-link "https://github.com/fsharp/FsAutoComplete") :group 'eglot) (defcustom eglot-fsharp-server-path "~/.dotnet/tools/" "Path to the location of FsAutoComplete." :group 'eglot-fsharp :risky t) (defcustom eglot-fsharp-server-install-dir (locate-user-emacs-file "FsAutoComplete/") "Install directory for FsAutoComplete." :group 'eglot-fsharp :risky t :type '(choice directory (const :tag "Use dotnet default for tool-path" nil))) (defcustom eglot-fsharp-server-version 'latest "FsAutoComplete version to install or update." :group 'eglot-fsharp :risky t :type '(choice (const :tag "Latest release" latest) (string :tag "Version string"))) (defcustom eglot-fsharp-server-args '("--adaptive-lsp-server-enabled") "Arguments for the fsautocomplete command when using `eglot-fsharp'." :type '(repeat string)) (defcustom eglot-fsharp-fsautocomplete-args '( :automaticWorkspaceInit t :abstractClassStubGeneration t :abstractClassStubGenerationMethodBody "failwith \"Not Implemented\"" :abstractClassStubGenerationObjectIdentifier "this" :addFsiWatcher nil :codeLenses (:references (:enabled t) :signature (:enabled t)) :disableFailedProjectNotifications nil :dotnetRoot "" :enableAdaptiveLspServer t :enableAnalyzers nil :enableMSBuildProjectGraph nil :enableReferenceCodeLens t :excludeProjectDirectories [".git" "paket-files" ".fable" "packages" "node_modules"] :externalAutocomplete nil :fsac (:attachDebugger nil :cachedTypeCheckCount 200 :conserveMemory nil :dotnetArgs nil :netCoreDllPath "" :parallelReferenceResolution nil :silencedLogs nil) :fsiExtraParameters nil :fsiSdkFilePath "" :generateBinlog nil :indentationSize 4 :inlayHints (:disableLongTooltip nil :enabled t :parameterNames t :typeAnnotations t) :inlineValues (:enabled nil :prefix "//") :interfaceStubGeneration t :interfaceStubGenerationMethodBody "failwith \"Not Implemented\"" :interfaceStubGenerationObjectIdentifier "this" :keywordsAutocomplete t :lineLens (:enabled "replaceCodeLens" :prefix " // ") :linter t :pipelineHints (:enabled t :prefix " // ") :recordStubGeneration t :recordStubGenerationBody "failwith \"Not Implemented\"" :resolveNamespaces t :saveOnSendLastSelection nil :simplifyNameAnalyzer t :smartIndent nil :suggestGitignore t :suggestSdkScripts t :unionCaseStubGeneration t :unionCaseStubGenerationBody "failwith \"Not Implemented\"" :unusedDeclarationsAnalyzer t :unusedOpensAnalyzer t :verboseLogging nil :workspaceModePeekDeepLevel 4 :workspacePath "") "Arguments for the fsautocomplete workspace configuration." :group 'eglot-fsharp :risky t ) (defun eglot-fsharp--path-to-server () "Return FsAutoComplete path." (let ((base (if eglot-fsharp-server-install-dir (concat eglot-fsharp-server-install-dir "netcore/") eglot-fsharp-server-path))) (expand-file-name (concat base "fsautocomplete" (if (eq system-type 'windows-nt) ".exe" ""))))) ;; cache to prevent repetitive queries (defvar eglot-fsharp--latest-version nil "Latest fsautocomplete.exe version string.") (defun eglot-fsharp--latest-version () "Return latest fsautocomplete.exe version." (let* ((json (with-temp-buffer (url-insert-file-contents "https://azuresearch-usnc.nuget.org/query?q=fsautocomplete&prerelease=false&packageType=DotnetTool") (json-parse-buffer))) (versions (gethash "versions" (aref (gethash "data" json) 0)))) (gethash "version" (aref versions (1- (length versions)))))) (defun eglot-fsharp--installed-version () "Return version string of fsautocomplete." (with-temp-buffer (if eglot-fsharp-server-install-dir (process-file "dotnet" nil t nil "tool" "list" "--tool-path" (file-name-directory (eglot-fsharp--path-to-server))) (process-file "dotnet" nil t nil "tool" "list" "-g")) (goto-char (point-min)) (when (search-forward-regexp "^fsautocomplete[[:space:]]+\\([0-9\.]*\\)[[:space:]]+" nil t) (match-string 1)))) (defun eglot-fsharp-current-version-p (version) "Return t if the installation is up-to-date compared to VERSION string." (and (file-exists-p (concat (file-remote-p default-directory) (eglot-fsharp--path-to-server))) (equal version (eglot-fsharp--installed-version)))) (defun eglot-fsharp--install-core (version) "Download and install fsautocomplete as a dotnet tool at version VERSION in `eglot-fsharp-server-install-dir'." (let* ((default-directory (concat (file-remote-p default-directory) (file-name-directory (eglot-fsharp--path-to-server)))) (stderr-file (make-temp-file "dotnet_stderr")) (local-tool-path (or (file-remote-p default-directory 'localname) default-directory)) (process-file-uninstall-args (if eglot-fsharp-server-install-dir (list "dotnet" nil `(nil ,stderr-file) nil "tool" "uninstall" "fsautocomplete" "--tool-path" local-tool-path) (list "dotnet" nil `(nil ,stderr-file) nil "tool" "uninstall" "-g" "fsautocomplete"))) (process-file-install-args (if eglot-fsharp-server-install-dir (list "dotnet" nil `(nil ,stderr-file) nil "tool" "install" "fsautocomplete" "--tool-path" local-tool-path "--version" version) (list "dotnet" nil `(nil ,stderr-file) nil "tool" "install" "fsautocomplete" "-g" "--version" version)))) (make-directory default-directory t) (condition-case err (progn (unless (or (eglot-fsharp-current-version-p version) (not (eglot-fsharp--installed-version))) (message "Uninstalling fsautocomplete version %s" (eglot-fsharp--installed-version)) (unless (zerop (apply #'process-file process-file-uninstall-args)) (error "'dotnet tool uninstall fsautocomplete ... failed"))) (unless (zerop (apply #'process-file process-file-install-args)) (error "'dotnet tool install fsautocomplete --tool-path %s --version %s' failed" default-directory version))) (error (let ((stderr (with-temp-buffer (insert-file-contents stderr-file) (buffer-string)))) (delete-file stderr-file) (signal (car err) (format "%s: %s" (cdr err) stderr))))) (message "Installed fsautocomplete to %s" (eglot-fsharp--path-to-server)))) (defun eglot-fsharp--maybe-install (&optional version) "Downloads F# compiler service, and install in `eglot-fsharp-server-install-dir'." (unless eglot-fsharp-server-install-dir (make-directory (concat (file-remote-p default-directory) (file-name-directory (eglot-fsharp--path-to-server))) t)) (let* ((version (or version (if (eq eglot-fsharp-server-version 'latest) (eglot-fsharp--latest-version) eglot-fsharp-server-version)))) (unless (eglot-fsharp-current-version-p version) (eglot-fsharp--install-core version)))) ;;;###autoload (defun eglot-fsharp (interactive) "Return `eglot' contact when FsAutoComplete is installed. Ensure FsAutoComplete is installed (when called INTERACTIVE)." (when interactive (eglot-fsharp--maybe-install)) (cons 'eglot-fsautocomplete (if (file-remote-p default-directory) `("sh" ,shell-command-switch ,(concat "cat|" (mapconcat #'shell-quote-argument (cons (eglot-fsharp--path-to-server) eglot-fsharp-server-args) " "))) (cons (eglot-fsharp--path-to-server) eglot-fsharp-server-args)))) (defclass eglot-fsautocomplete (eglot-lsp-server) () :documentation "F# FsAutoComplete langserver.") (cl-defmethod eglot-initialization-options ((_server eglot-fsautocomplete)) "Passes through required FsAutoComplete initialization options." eglot-fsharp-fsautocomplete-args) ;; FIXME: this should be fixed in FsAutocomplete (cl-defmethod xref-backend-definitions :around ((_type symbol) _identifier) "FsAutoComplete breaks spec and and returns error instead of empty list." (if (eq major-mode 'fsharp-mode) (condition-case err (cl-call-next-method) (jsonrpc-error (not (equal (cadddr err) '(jsonrpc-error-message . "Could not find declaration"))))) (when (cl-next-method-p) (cl-call-next-method)))) (add-to-list 'eglot-server-programs `(fsharp-mode . eglot-fsharp)) (provide 'eglot-fsharp) ;;; eglot-fsharp.el ends here ================================================ FILE: fsharp-mode-font.el ================================================ ;;; fsharp-mode-font.el --- Syntax highlighting for F# ;; Copyright (C) 1997 INRIA ;; Author: 1993-1997 Xavier Leroy, Jacques Garrigue and Ian T Zimmerman ;; 2010-2011 Laurent Le Brun ;; Maintainer: Robin Neatherway ;; Keywords: languages ;; This file is not part of GNU Emacs. ;; This file is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; This file is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;;; Code: (defgroup fsharp-ui nil "F# UI group for the defcustom interface." :prefix "fsharp-ui-" :group 'fsharp :package-version '(fsharp-mode . "1.9.2")) (defface fsharp-ui-generic-face '((t (:inherit default))) "Preprocessor face" :group 'fsharp-ui) (defface fsharp-ui-operator-face '((t (:foreground "LightSkyBlue"))) "Preprocessor face" :group 'fsharp-ui) (defface fsharp-ui-warning-face '((t (:inherit font-lock-warning-face))) "Face for warnings." :group 'fsharp-ui) (defface fsharp-ui-error-face '((t (:inherit font-lock-error-face :underline t))) "Face for errors" :group 'fsharp-ui) (defmacro def-fsharp-compiled-var (sym init &optional docstring) "Defines a SYMBOL as a constant inside an eval-and-compile form with initial value INITVALUE and optional DOCSTRING." `(eval-and-compile (defvar ,sym ,init ,docstring))) (def-fsharp-compiled-var fsharp-shebang-regexp "\\(^#!.*?\\)\\([A-Za-z0-9_-]+\\)$" "Capture the #! and path of a shebag in one group and the executable in another.") (def-fsharp-compiled-var fsharp-access-control-regexp "private\\s-+\\|internal\\s-+\\|public\\s-+" "Match `private', `internal', or `public', followed by a space, with no capture.") (def-fsharp-compiled-var fsharp-access-control-regexp-noncapturing (format "\\(?:%s\\)" fsharp-access-control-regexp) "Same as `fsharp-access-control-regexp', but captures") (def-fsharp-compiled-var fsharp-inline-rec-regexp "inline\\s-+\\|rec\\s-+" "Match `inline' or `rec', followed by a space.") (def-fsharp-compiled-var fsharp-inline-rec-regexp-noncapturing (format "\\(?:%s\\)" fsharp-inline-rec-regexp) "Match `inline' or `rec', followed by a space, with no capture.") (def-fsharp-compiled-var fsharp-valid-identifier-regexp "[A-Za-z0-9_']+" "Match a normal, valid F# identifier -- alphanumeric characters plus ' and underbar. Does not capture") (def-fsharp-compiled-var fsharp-function-def-regexp (concat "\\<\\(?:let\\|and\\|with\\)\\s-+" fsharp-inline-rec-regexp-noncapturing "?" fsharp-access-control-regexp-noncapturing "*" (format "\\(%s\\)" fsharp-valid-identifier-regexp) "\\(?:\\s-+[A-Za-z_]\\|\\s-*(\\)" ;; matches function arguments or open-paren; unclear why 0-9 not in class )) (def-fsharp-compiled-var fsharp-pattern-function-regexp (concat "\\<\\(?:let\\|and\\)\\s-+" fsharp-inline-rec-regexp-noncapturing "?" fsharp-access-control-regexp-noncapturing "*" (format "\\(%s\\)" fsharp-valid-identifier-regexp) "\\s-*=\\s-*function") "Matches an implicit matcher, eg let foo m = function | \"cat\" -> etc.") ;; Note that this regexp is used for iMenu. To font-lock active patterns, we ;; need to use an anchored match in fsharp-font-lock-keywords. (def-fsharp-compiled-var fsharp-active-pattern-regexp (concat "\\<\\(?:let\\|and\\)\\s-+" fsharp-inline-rec-regexp-noncapturing "?" fsharp-access-control-regexp-noncapturing "*" "(\\(|[A-Za-z0-9_'|]+|\\))\\(?:\\s-+[A-Za-z_]\\|\\s-*(\\)")) (def-fsharp-compiled-var fsharp-member-access-regexp "\\<\\(?:override\\|member\\|abstract\\)\\s-+" "Matches members declarations and modifiers on classes.") (def-fsharp-compiled-var fsharp-member-function-regexp (concat fsharp-member-access-regexp fsharp-inline-rec-regexp-noncapturing "?" fsharp-access-control-regexp-noncapturing "*" "\\(?:" fsharp-valid-identifier-regexp "\\.\\)?" "\\(" fsharp-valid-identifier-regexp "\\)") "Captures the final identifier in a member function declaration.") (def-fsharp-compiled-var fsharp-overload-operator-regexp (concat fsharp-member-access-regexp fsharp-inline-rec-regexp-noncapturing "?" fsharp-access-control-regexp-noncapturing "*" "\\(([!%&*+-./<=>?@^|~]+)\\)") "Match operators when overloaded by a type/class.") (def-fsharp-compiled-var fsharp-constructor-regexp (concat "^\\s-*" fsharp-access-control-regexp-noncapturing "*" "\\<\\(new\\) *(.*)[^=]*=") "Matches the `new' keyword in a constructor") (def-fsharp-compiled-var fsharp-type-def-regexp (concat "^\\s-*\\<\\(?:type\\|inherit\\)\\s-+" fsharp-access-control-regexp-noncapturing "*" ;; match access control 0 or more times "\\([A-Za-z0-9_'.]+\\)")) (def-fsharp-compiled-var fsharp-var-or-arg-regexp "\\_<\\([A-Za-z_][A-Za-z0-9_']*\\)\\_>") (def-fsharp-compiled-var fsharp-explicit-field-regexp (concat "^\\s-*\\(?:val\\|abstract\\)\\s-*\\(?:mutable\\s-+\\)?" fsharp-access-control-regexp-noncapturing "*" ;; match access control 0 or more times "\\([A-Za-z_][A-Za-z0-9_']*\\)\\s-*:\\s-*\\([A-Za-z_][A-Za-z0-9_'<> \t]*\\)")) (def-fsharp-compiled-var fsharp-attributes-regexp "\\(\\[<[A-Za-z0-9_]+[( ]?\\)\\(\".*\"\\)?\\()?>\\]\\)" "Match attributes like []; separately groups contained strings in attributes like []") ;; F# makes extensive use of operators, many of which have some kind of ;; structural significance. ;; ;; In particular: ;; (| ... |) -- banana clips for Active Patterns (handled separately) ;; <@ ... @> and <@@ ... @@> -- quoted expressions ;; <| and |> -- left and right pipe (also <||, <|||, ||>, |||>) ;; << and >> -- function composition ;; | -- match / type expressions (def-fsharp-compiled-var fsharp-operator-quote-regexp "\\(<@\\{1,2\\}\\)\\(?:.*\\)\\(@\\{1,2\\}>\\)" "Font lock <@/<@@ and @>/@@> operators.") (def-fsharp-compiled-var fsharp-operator-pipe-regexp "<|\\{1,3\\}\\||\\{1,3\\}>" "Match the full range of pipe operators -- |>, ||>, |||>, etc.") (def-fsharp-compiled-var fsharp-custom-operator-with-pipe-regexp (let ((op-chars "!%&\\*\\+\\-\\./<=>@\\^~") ;; all F# custom operator chars except for `|` (backward-pipe "<|\\{1,3\\}") (forward-pipe "|\\{1,3\\}>") (alt "\\|")) (concat "[" op-chars "|]*" backward-pipe "[" op-chars "]+" alt "[" op-chars "|]+" backward-pipe "[" op-chars "]*" alt "[" op-chars "]*" forward-pipe "[" op-chars "|]+" alt "[" op-chars "]+" forward-pipe "[" op-chars "|]*")) "Match operators that contains pipe sequence -- <|>, |>>, <<|, etc.") (def-fsharp-compiled-var fsharp-operator-case-regexp "\\s-+\\(|\\)[A-Za-z0-9_' ]" "Match literal | in contexts like match and type declarations.") (defvar fsharp-imenu-generic-expression `((nil ,(concat "^\\s-*" fsharp-function-def-regexp) 1) (nil ,(concat "^\\s-*" fsharp-pattern-function-regexp) 1) ("Active Pattern" ,(concat "^\\s-*" fsharp-active-pattern-regexp) 1) ("Member" ,(concat "^\\s-*" fsharp-member-function-regexp) 1) ("Overload Operator" ,(concat "^\\s-*" fsharp-overload-operator-regexp) 1) ("Constructor" ,fsharp-constructor-regexp 1) ("Type" ,fsharp-type-def-regexp 1) ("Module" ,(concat "\\s-*module " fsharp-var-or-arg-regexp) 1)) "Provide iMenu support through font-locking regexen.") (defun fsharp-imenu-load-index () "Hook up the provided regexen to enable imenu support." (setq imenu-generic-expression fsharp-imenu-generic-expression)) (add-hook 'fsharp-mode-hook #'fsharp-imenu-load-index) (defun fsharp-var-pre-form () (save-excursion (re-search-forward "\\(:\\s-*\\w[^)]*\\)?=" nil t) (match-beginning 0))) (defun fsharp-fun-pre-form () (save-excursion (search-forward "->"))) ;; Preprocessor directives (3.3) (def-fsharp-compiled-var fsharp-ui-preproessor-directives '("#if" "#else" "#endif" "#light")) ;; Compiler directives (12.4) (def-fsharp-compiled-var fsharp-ui-compiler-directives '("#nowarn" "#load" "#r" "#reference" "#I" "#Include" "#q" "#quit" "#time" "#help")) ;; Lexical matters (18.4) (def-fsharp-compiled-var fsharp-ui-lexical-matters '("#indent")) ;; Line Directives (3.9) (def-fsharp-compiled-var fsharp-ui-line-directives '("#line")) ;; Identifier replacements (3.11) (def-fsharp-compiled-var fsharp-ui-identifier-replacements '("__SOURCE_DIRECTORY__" "__SOURCE_FILE__" "__LINE__")) ;; F# keywords (5.0) (def-fsharp-compiled-var fsharp-ui-fsharp-threefour-keywords '("abstract" "and" "and!" "as" "assert" "base" "begin" "class" "default" "delegate" "do" "do!" "done" "downcast" "downto" "elif" "else" "end" "exception" "extern" "false" "finally" "for" "fun" "function" "global" "if" "in" "inherit" "inline" "interface" "internal" "lazy" "let" "let!" "match" "match!" "member" "module" "mutable" "namespace" "new" "not" "null" "of" "open" "or" "override" "private" "public" "rec" "return" "return!" "select" "static" "struct" "then" "to" "true" "try" "type" "upcast" "use" "use!" "val" "void" "when" "while" "with" "yield" "yield!")) ;; "Reserved because they are reserved in OCaml" (def-fsharp-compiled-var fsharp-ui-ocaml-reserved-words '("asr" "land" "lor" "lsl" "lsr" "lxor" "mod" "sig")) ;; F# reserved words for future use (def-fsharp-compiled-var fsharp-ui-reserved-words '("atomic" "break" "checked" "component" "const" "constraint" "constructor" "continue" "eager" "event" "external" "fixed" "functor" "include" "method" "mixin" "object" "parallel" "process" "protected" "pure" "sealed" "tailcall" "trait" "virtual" "volatile")) ;; RMD 2016-09-30 -- This was pulled out separately with the following comment ;; when I got here. Not clear to me why it's on it's own, or even precisely what ;; the comment means. But: `async' is a valid F# keyword and needs to go someplace, ;; so I've left it here. For now. ;; ;; Workflows not yet handled by fsautocomplete but async ;; always present (def-fsharp-compiled-var fsharp-ui-async-words '("async") "Just the word async, in a list.") (def-fsharp-compiled-var fsharp-ui-word-list-regexp (regexp-opt `(,@fsharp-ui-async-words ,@fsharp-ui-compiler-directives ,@fsharp-ui-fsharp-threefour-keywords ,@fsharp-ui-identifier-replacements ,@fsharp-ui-lexical-matters ,@fsharp-ui-ocaml-reserved-words ,@fsharp-ui-preproessor-directives ,@fsharp-ui-reserved-words ,@fsharp-ui-line-directives) 'symbols)) (defconst fsharp-font-lock-keywords (eval-when-compile `((,fsharp-ui-word-list-regexp 0 font-lock-keyword-face) ;; shebang (,fsharp-shebang-regexp (1 font-lock-comment-face) (2 font-lock-keyword-face)) ;; attributes (,fsharp-attributes-regexp (1 font-lock-preprocessor-face) (2 font-lock-string-face nil t) (3 font-lock-preprocessor-face)) ;; ;; type defines (,fsharp-type-def-regexp 1 font-lock-type-face) (,fsharp-function-def-regexp 1 font-lock-function-name-face) (,fsharp-pattern-function-regexp 1 font-lock-function-name-face) ;; Active Pattern ("(|" (0 'fsharp-ui-operator-face) ("\\([A-Za-z'_]+\\)\\(|)?\\)" nil nil (1 font-lock-function-name-face) (2 'fsharp-ui-operator-face))) (,fsharp-custom-operator-with-pipe-regexp . 'fsharp-ui-generic-face) (,fsharp-operator-pipe-regexp . 'fsharp-ui-operator-face) (,fsharp-member-function-regexp 1 font-lock-function-name-face) (,fsharp-overload-operator-regexp 1 font-lock-function-name-face) (,fsharp-constructor-regexp 1 font-lock-function-name-face) (,fsharp-operator-case-regexp 1 'fsharp-ui-operator-face) (,fsharp-operator-quote-regexp (1 'fsharp-ui-operator-face) (2 'fsharp-ui-operator-face)) ("[^:]:\\s-*\\(\\<[A-Za-z0-9_' ]*[^ ;\n,)}=<-]\\)\\(<[^>]*>\\)?" (1 font-lock-type-face) ;; 'prevent generic type arguments from being rendered in variable face (2 'fsharp-ui-generic-face nil t)) (,(format "^\\s-*\\<\\(let\\|use\\|override\\|member\\|and\\|\\(?:%snew\\)\\)\\_>" (concat fsharp-access-control-regexp "*")) (0 font-lock-keyword-face) ; let binding and function arguments (,fsharp-var-or-arg-regexp (fsharp-var-pre-form) nil (1 font-lock-variable-name-face nil t))) ("\\" (0 font-lock-keyword-face) ; lambda function arguments (,fsharp-var-or-arg-regexp (fsharp-fun-pre-form) nil (1 font-lock-variable-name-face nil t))) (,fsharp-type-def-regexp (0 'font-lock-keyword-face) ; implicit constructor arguments (,fsharp-var-or-arg-regexp (fsharp-var-pre-form) nil (1 font-lock-variable-name-face nil t))) (,fsharp-explicit-field-regexp (1 font-lock-variable-name-face) (2 font-lock-type-face)) ;; open namespace ("\\@^|~?]*[\n\t\r\b\a\f\v ]*\)" (1 "()")) ; symbolic operator starting (* is not a comment ("\\(/\\)\\*" (1 "."))) start end)) (defun fsharp--syntax-string (end) (let* ((pst (syntax-ppss)) (instr (nth 3 pst)) (start (nth 8 pst))) (when (eq t instr) ; Then we are in a custom string (cond ((eq ?@ (char-after start)) ; Then we are in a verbatim string (while (when (re-search-forward "\"\"?" end 'move) (if (> (- (match-end 0) (match-beginning 0)) 1) t ;; Skip this "" and keep looking further. (put-text-property (- (match-beginning 0) 1) (- (match-end 0) 1) 'syntax-table (string-to-syntax ".")) (put-text-property (match-beginning 0) (match-end 0) 'syntax-table (string-to-syntax "|")) nil)))) (t ; Then we are in a triple-quoted string (when (re-search-forward "\"\"\"" end 'move) (put-text-property (- (match-beginning 0) 1) (match-beginning 0) 'syntax-table (string-to-syntax ".")) (put-text-property (match-beginning 0) (match-end 0) 'syntax-table (string-to-syntax "|")))))))) (provide 'fsharp-mode-font) ;;; fsharp-mode-font.el ends here ================================================ FILE: fsharp-mode-structure.el ================================================ ;;; fsharp-mode-indent.el --- Stucture Definition, Mark, and Motion for F# ;; Copyright (C) 2010 Laurent Le Brun ;; Author: 2010-2011 Laurent Le Brun ;; Maintainer: Jürgen Hötzel ;; Keywords: languages ;; This file is not part of GNU Emacs. ;; This file is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; This file is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; This module defines variables and functions related to the structure of F# ;; code, and motion around and through that code. SMIE is used to set certain ;; default configurations. In particular, `smie' expects to set ;; `forward-sexp-function' and `indent-line-function', the latter of which we ;; currently override. ;; ;; SMIE configs by m00nlight Wang , 2015 ;; Last major update by Ross Donaldson <@gastove>, 2019 ;;; Code: (require 'comint) (require 'custom) (require 'compile) (require 'smie) ;;-------------------------- Customization Variables --------------------------;; (defcustom fsharp-tab-always-indent t "*Non-nil means TAB in Fsharp mode should always reindent the current line, regardless of where in the line point is when the TAB command is used." :type 'boolean :group 'fsharp) (defcustom fsharp-indent-offset 4 "*Amount of offset per level of indentation. `\\[fsharp-guess-indent-offset]' can usually guess a good value when you're editing someone else's Fsharp code." :type 'integer :group 'fsharp) (defalias 'fsharp-indent-level 'fsharp-indent-offset "Backwards-compatibility alias. `fsharp-indent-level' was configuring the same thing as `fsharp-indent-offset', but less clearly and in a different file, and free from update by functions like offset-guessing.") (defcustom fsharp-continuation-offset 4 "*Additional amount of offset to give for some continuation lines. Continuation lines are those that immediately follow a backslash terminated line. Only those continuation lines for a block opening statement are given this extra offset." :type 'integer :group 'fsharp) (defcustom fsharp-conservative-indentation-after-bracket nil "Indent by fsharp-continuation-offset also after an opening bracket. The default indentation depth on a new line after an opening bracket is one column further from the opening bracket. Indenting much less is allowed, because brackets reset the current offside column." :type 'boolean :group 'fsharp) (defcustom fsharp-smart-indentation t "*Should `fsharp-mode' try to automagically set some indentation variables? When this variable is non-nil, two things happen when a buffer is set to `fsharp-mode': 1. `fsharp-indent-offset' is guessed from existing code in the buffer. Only guessed values between 2 and 8 are considered. If a valid guess can't be made (perhaps because you are visiting a new file), then the value in `fsharp-indent-offset' is used. 2. `indent-tabs-mode' is turned off if `fsharp-indent-offset' does not equal `tab-width' (`indent-tabs-mode' is never turned on by Fsharp mode). This means that for newly written code, tabs are only inserted in indentation if one tab is one indentation level, otherwise only spaces are used. Note that both these settings occur *after* `fsharp-mode-hook' is run, so if you want to defeat the automagic configuration, you must also set `fsharp-smart-indentation' to nil in your `fsharp-mode-hook'." :type 'boolean :group 'fsharp) (defcustom fsharp-honor-comment-indentation t "*Controls how comment lines influence subsequent indentation. When nil, all comment lines are skipped for indentation purposes, and if possible, a faster algorithm is used (i.e. X/Emacs 19 and beyond). When t, lines that begin with a single `//' are a hint to subsequent line indentation. If the previous line is such a comment line (as opposed to one that starts with `fsharp-block-comment-prefix'), then its indentation is used as a hint for this line's indentation. Lines that begin with `fsharp-block-comment-prefix' are ignored for indentation purposes. When not nil or t, comment lines that begin with a single `//' are used as indentation hints, unless the comment character is in column zero." :type '(choice (const :tag "Skip all comment lines (fast)" nil) (const :tag "Single // `sets' indentation for next line" t) (const :tag "Single // `sets' indentation except at column zero" other) ) :group 'fsharp) (defcustom fsharp-backspace-function 'backward-delete-char-untabify "*Function called by `fsharp-electric-backspace' when deleting backwards." :type 'function :group 'fsharp) (defcustom fsharp-delete-function 'delete-char "*Function called by `fsharp-electric-delete' when deleting forwards." :type 'function :group 'fsharp) ;;--------------------------------- Constants ---------------------------------;; ;; TODO[gastove|2019-10-30] So much: ;; - No SQTQ in F# ;; - No raw strings either ;; - But there *are* verbatim strings that begin with @ ;; - And can use \ to escape a newline ;; - But *can* contain newlines ;; It's a good thing this isn't called often, because it is a mess and wrong. (defconst fsharp-stringlit-re (concat ;; These fail if backslash-quote ends the string (not worth ;; fixing?). They precede the short versions so that the first two ;; quotes don't look like an empty short string. ;; ;; (maybe raw), long single quoted triple quoted strings (SQTQ), ;; with potential embedded single quotes "[rR]?'''[^']*\\(\\('[^']\\|''[^']\\)[^']*\\)*'''" "\\|" ;; (maybe raw), long double quoted triple quoted strings (DQTQ), ;; with potential embedded double quotes "[rR]?\"\"\"[^\"]*\\(\\(\"[^\"]\\|\"\"[^\"]\\)[^\"]*\\)*\"\"\"" "\\|" "[rR]?'\\([^'\n\\]\\|\\\\.\\)*'" ; single-quoted "\\|" ; or "[rR]?\"\\([^\"\n\\]\\|\\\\.\\)*\"" ; double-quoted ) "Regular expression matching a Fsharp string literal.") (defconst fsharp--hanging-operator-re (concat ".*\\(" (mapconcat 'identity '("+" "-" "*" "/") "\\|") "\\)$") "Regular expression matching unterminated algebra expressions.") ;; TODO[gastove|2019-10-22] This doesn't match (* long comments *), but it *does* capture. (defconst fsharp-blank-or-comment-re "[ \t]*\\(//.*\\)?" "Regular expression matching a blank or comment line.") (defconst fsharp-outdent-re (concat "\\(" (mapconcat 'identity '("else" "with" "finally" "end" "done" "elif" "}") "\\|") "\\)") "Regular expression matching statements to be dedented one level.") (defconst fsharp-block-closing-keywords-re "\\(end\\|done\\|raise\\|failwith\\|failwithf\\|rethrow\\|exit\\)" "Regular expression matching keywords which typically close a block.") (defconst fsharp-no-outdent-re (concat "\\(" (mapconcat 'identity (list "try" "while\\s +.*" "for\\s +.*" "then" (concat fsharp-block-closing-keywords-re "[ \t\n]") ) "\\|") "\\)") "Regular expression matching lines not to dedent after.") (defconst fsharp-block-opening-re (concat "\\(" (mapconcat 'identity '("then" "else" "with" "finally" "class" "struct" "=" ; for example: let f x = "->" "do" "try" "function") "\\|") "\\)") "Regular expression matching expressions which begin a block") ;; TODO: this regexp looks transparently like a python regexp. That means it's almost certainly wrong. (defvar fsharp-parse-state-re (concat "^[ \t]*\\(elif\\|else\\|while\\|def\\|class\\)\\>" "\\|" "^[^ /\t\n]")) (defsubst fsharp-point (position) "Returns the value of point at certain commonly referenced POSITIONs. POSITION can be one of the following symbols: bol -- beginning of line eol -- end of line bod -- beginning of def or class eod -- end of def or class bob -- beginning of buffer eob -- end of buffer boi -- back to indentation bos -- beginning of statement This function preserves point and mark." (save-mark-and-excursion (cond ((eq position 'bol) (beginning-of-line)) ((eq position 'eol) (end-of-line)) ((eq position 'bod) (fsharp-beginning-of-def-or-class 'either)) ((eq position 'eod) (fsharp-end-of-def-or-class 'either)) ((eq position 'bob) (point-min)) ((eq position 'eob) (point-max)) ((eq position 'boi) (back-to-indentation)) ((eq position 'bos) (fsharp-goto-initial-line)) (t (error "Unknown buffer position requested: %s" position))) (point))) ;;-------------------------------- Predicates --------------------------------;; (defun fsharp-in-literal-p (&optional lim) "Return non-nil if point is in a Fsharp literal (a comment or string). The return value is specifically one of the symbols \\='comment or \\='string. Optional argument LIM indicates the beginning of the containing form, i.e. the limit on how far back to scan." ;; NOTE: Watch out for infinite recursion between this function and ;; `fsharp-point'. (let* ((lim (or lim (fsharp-point 'bod))) (state (parse-partial-sexp lim (point)))) (cond ((nth 3 state) 'string) ((nth 4 state) 'comment) (t nil)))) (defun fsharp-outdent-p () "Returns non-nil if the current line should dedent one level." (save-excursion (progn (back-to-indentation) (looking-at fsharp-outdent-re)))) (defun fsharp--indenting-comment-p () "Returns non-nil if point is in an indenting comment line, otherwise nil. Definition: Indenting comment line. A line containing only a comment, but which is treated like a statement for indentation calculation purposes. Such lines are only treated specially by the mode; they are not treated specially by the Fsharp interpreter. The first non-blank line following an indenting comment line is given the same amount of indentation as the indenting comment line. All other comment-only lines are ignored for indentation purposes. Are we looking at a comment-only line which is *not* an indenting comment line? If so, we assume that it's been placed at the desired indentation, so leave it alone. Indenting comment lines are aligned as statements." ;; TODO[gastove|2019-10-22] this is a bug. The regular expression here matches ;; comments only if there is *no whites space* between the // and the first ;; characters in the comment. (and (looking-at "[ \t]*//[^ \t\n]") (fboundp 'forward-comment) (<= (current-indentation) (save-excursion (forward-comment (- (point-max))) (current-indentation))))) (defun fsharp--hanging-operator-continuation-line-p () "Return t if point is on at least the *second* line of the buffer, and the previous line matches `fsharp--hanging-operator-re' -- which is to say, it ends in +, -, /, or *." (save-excursion (beginning-of-line) (and (not (bobp)) ;; make sure; since eq test passed, there is a preceding line (forward-line -1) ; always true -- side effect ;; matches any line, so long as it ends with one of +, -, *, or / (looking-at fsharp--hanging-operator-re)))) ;; TODO[gastove|2019-10-31] This function doesn't do everything it needs to. ;; Currently, it only reports a continuation line if there's a hanging ;; arithmetic operator *or* if we're inside a delimited block (something like {} ;; or []). It _needs_ to also respect symbols that open a new whitespace block ;; -- things like -> at the end of a line, or |> at the beginning of one. ;; ;; The trick is: the other major place where |> and -> lines are considered is ;; in `fsharp-compute-indentation', which... catches "undelimited" blocks as a ;; default case. They aren't _explicitly_ detected. ;; ;; In all, this makes me think we need a cleaner distinction between a ;; "continuation line" and a "relative line" -- that is, a line that continues ;; an ongoing expression (a sequence of items in a list, the completion of an ;; arithmetic expression) and a new block scope opened by a single symbol and ;; terminated with whitespace. ;; ;; We do already have `fsharp-statement-opens-block-p', which we could make much ;; more active use of. However: `fsharp-statement-opens-block-p' calls ;; `fsharp-goto-beyond-final-line', which... relies on ;; `fsharp-continuation-line-p'. So that will need untangling. (defun fsharp-continuation-line-p () "Return t if current line continues a line with a hanging arithmetic operator *or* is inside a nesting construct (a list, computation expression, etc)." (save-excursion (beginning-of-line) (or (fsharp--hanging-operator-continuation-line-p) (fsharp-nesting-level)))) (defun fsharp--previous-line-continuation-line-p () "Returns true if previous line is a continuation line" (save-excursion (forward-line -1) (fsharp-continuation-line-p))) (defun fsharp-statement-opens-block-p () "Return t if the current statement opens a block. For instance: type Shape = | Square | Rectangle or: let computation = [ this; that ] |> Array.someCalculation Point should be at the start of a statement." (save-excursion (let ((start (point)) (finish (progn (fsharp-goto-beyond-final-line) (1- (point)))) (searching t) (answer nil) state) (goto-char start) ;; Keep searching until we're finished. (while searching (if (re-search-forward fsharp-block-opening-re finish t) (if (eq (point) finish) ;; sure looks like it opens a block -- but it might ;; be in a comment (progn (setq searching nil) ; search is done either way (setq state (parse-partial-sexp start (match-beginning 0))) (setq answer (not (nth 4 state))))) ;; search failed: couldn't find a reason to believe we're opening a block. (setq searching nil))) answer))) ;; TODO[@gastove|2019-10-22]: the list of keywords this function claims to catch ;; does not at all match the keywords in the regexp it wraps. (defun fsharp-statement-closes-block-p () "Return t iff the current statement closes a block. I.e., if the line starts with `return', `raise', `break', `continue', and `pass'. This doesn't catch embedded statements." (let ((here (point))) (fsharp-goto-initial-line) (back-to-indentation) (prog1 (looking-at (concat fsharp-block-closing-keywords-re "\\>")) (goto-char here)))) ;;---------------------------- Electric Keystrokes ----------------------------;; (defun fsharp-electric-colon (arg) "Insert a colon. In certain cases the line is dedented appropriately. If a numeric argument ARG is provided, that many colons are inserted non-electrically. Electric behavior is inhibited inside a string or comment." (interactive "*P") (self-insert-command (prefix-numeric-value arg)) ;; are we in a string or comment? (if (save-excursion (let ((pps (parse-partial-sexp (save-excursion (fsharp-beginning-of-def-or-class) (point)) (point)))) (not (or (nth 3 pps) (nth 4 pps))))) (save-excursion (let ((here (point)) (outdent 0) (indent (fsharp-compute-indentation t))) (if (and (not arg) (fsharp-outdent-p) (= indent (save-excursion (fsharp-next-statement -1) (fsharp-compute-indentation t))) ) (setq outdent fsharp-indent-offset)) ;; Don't indent, only dedent. This assumes that any lines ;; that are already dedented relative to ;; fsharp-compute-indentation were put there on purpose. It's ;; highly annoying to have `:' indent for you. Use TAB, C-c ;; C-l or C-c C-r to adjust. TBD: Is there a better way to ;; determine this??? (if (< (current-indentation) indent) nil (goto-char here) (beginning-of-line) (delete-horizontal-space) (indent-to (- indent outdent))))))) ;; Electric deletion (defun fsharp-electric-backspace (arg) "Delete preceding character or levels of indentation. Deletion is performed by calling the function in `fsharp-backspace-function' with a single argument (the number of characters to delete). If point is at the leftmost column, delete the preceding newline. Otherwise, if point is at the leftmost non-whitespace character of a line that is neither a continuation line nor a non-indenting comment line, or if point is at the end of a blank line, this command reduces the indentation to match that of the line that opened the current block of code. The line that opened the block is displayed in the echo area to help you keep track of where you are. With \\[universal-argument] dedents that many blocks (but not past column zero). Otherwise the preceding character is deleted, converting a tab to spaces if needed so that only a single column position is deleted. \\[universal-argument] specifies how many characters to delete; default is 1. When used programmatically, argument ARG specifies the number of blocks to dedent, or the number of characters to delete, as indicated above." (interactive "*p") (if (or (/= (current-indentation) (current-column)) (bolp) (fsharp-continuation-line-p)) (funcall fsharp-backspace-function arg) ;; else indent the same as the colon line that opened the block ;; force non-blank so fsharp-goto-block-up doesn't ignore it (insert-char ?* 1) (backward-char) (let ((base-indent 0) ; indentation of base line (base-text "") ; and text of base line (base-found-p nil)) (save-excursion (while (< 0 arg) (condition-case nil ; in case no enclosing block (progn (fsharp-goto-block-up 'no-mark) (setq base-indent (current-indentation) base-text (fsharp-suck-up-leading-text) base-found-p t)) (error nil)) (setq arg (1- arg)))) (delete-char 1) ; toss the dummy character (delete-horizontal-space) (indent-to base-indent) (if base-found-p (message "Closes block: %s" base-text))))) (defun fsharp-electric-delete (arg) "Delete preceding or following character or levels of whitespace. The behavior of this function depends on the variable `delete-key-deletes-forward'. If this variable is nil (or does not exist, as in older Emacsen and non-XEmacs versions), then this function behaves identically to \\[c-electric-backspace]. If `delete-key-deletes-forward' is non-nil and is supported in your Emacs, then deletion occurs in the forward direction, by calling the function in `fsharp-delete-function'. \\[universal-argument] (programmatically, argument ARG) specifies the number of characters to delete (default is 1)." (interactive "*p") (funcall fsharp-delete-function arg)) ;; required for pending-del/delsel/delete-selection minor modes (put 'fsharp-electric-colon 'delete-selection t) ;delsel (put 'fsharp-electric-colon 'pending-delete t) ;pending-del (put 'fsharp-electric-backspace 'delete-selection 'supersede) ;delsel (put 'fsharp-electric-backspace 'pending-delete 'supersede) ;pending-del (put 'fsharp-electric-delete 'delete-selection 'supersede) ;delsel (put 'fsharp-electric-delete 'pending-delete 'supersede) ;pending-del ;;-------------------------------- Indentation --------------------------------;; (defun fsharp-indent-line (&optional arg) "Fix the indentation of the current line according to Fsharp rules. With \\[universal-argument] (programmatically, the optional argument ARG non-nil), ignore dedenting rules for block closing statements (e.g. return, raise, break, continue, pass) This function is normally bound to `indent-line-function' so \\[indent-for-tab-command] will call it." (interactive "P") (let* ((ci (current-indentation)) (move-to-indentation-p (<= (current-column) ci)) (need (fsharp-compute-indentation (not arg))) (cc (current-column))) ;; dedent out a level if previous command was the same unless we're in ;; column 1 (if (and (equal last-command this-command) (/= cc 0)) (progn (beginning-of-line) (delete-horizontal-space) (indent-to (* (/ (- cc 1) fsharp-indent-offset) fsharp-indent-offset))) (progn ;; see if we need to dedent (if (fsharp-outdent-p) (setq need (- need fsharp-indent-offset))) (if (or fsharp-tab-always-indent move-to-indentation-p) (progn (if (/= ci need) (save-excursion (beginning-of-line) (delete-horizontal-space) (indent-to need))) (if move-to-indentation-p (back-to-indentation))) (insert-tab)))))) ;; NOTE[gastove|2019-10-25] An interesting point: this function is *only* ever ;; called if `open-bracket-pos' is non-nil; `open-bracket-pos' is generated by ;; `fsharp-nesting-level', which *only* returns non nil for non-string ;; characters. And yet: we don't just rely on `open-bracket-pos' as we compute ;; indentation, and I'm honestly not sure why. (defun fsharp--compute-indentation-open-bracket (open-bracket-pos) "Computes indentation for a line within an open bracket expression." (save-excursion (let ((startpos (point)) placeholder) ;; align with first item in list; else a normal ;; indent beyond the line with the open bracket (goto-char (1+ open-bracket-pos)) ; just beyond bracket ;; NOTE[gastove|2019-10-25] -- consider switching to a forward regexp search ;; with a whitepsace character class. ;; is the first list item on the same line? (skip-chars-forward " \t") (if (and (null (memq (following-char) '(?\n ?# ?\\))) (not fsharp-conservative-indentation-after-bracket)) ; yes, so line up with it (current-column) ;; here follows the else ;; first list item on another line, or doesn't exist yet ;; TODO[gastove|2019-10-25] this needs to skip past whitespace, newlines, ;; *and* comments. I'm not convinced it does. (forward-line 1) (while (and (< (point) startpos) (looking-at "[ \t]*\\(//\\|[\n\\\\]\\)")) ; skip noise (forward-line 1)) (if (and (< (point) startpos) (/= startpos (save-excursion (goto-char (1+ open-bracket-pos)) (forward-comment (point-max)) (point)))) ;; again mimic the first list item (current-indentation) ;; else they're about to enter the first item ;; NOTE[gastove|2019-10-25] Okay, this is all really hard to follow, but ;; I *think* what's going on here is: ;; - We go to the position of the opening bracket we're trying to compute indentation against. ;; - We set placeholder to point (meaning we set `placeholder' to `open-bracket-pos') ;; - We call a function that claims to go to the first line of a statement ;; - We call a function that I *believe* tries to take us to the opening delimiter of a matched pair ;; - We return the current indentation of *that*, plus indent offset ;; ... holy moly. (goto-char open-bracket-pos) (setq placeholder (point)) (fsharp-goto-initial-line) (fsharp-goto-beginning-of-tqs (save-excursion (nth 3 (parse-partial-sexp placeholder (point))))) (+ (current-indentation) fsharp-indent-offset)))))) (defun fsharp--compute-indentation-continuation-line () "Computes the indentation for a line which continues the line above, but only when the previous line is not itself a continuation line." (save-excursion (forward-line -11) (let ((startpos (point)) (open-bracket-pos (fsharp-nesting-level)) endpos searching found state placeholder) ;; Started on 2nd line in block, so indent more. if base line is an ;; assignment with a start on a RHS, indent to 2 beyond the leftmost "="; ;; else skip first chunk of non-whitespace characters on base line, + 1 more ;; column (end-of-line) (setq endpos (point) searching t) (back-to-indentation) (setq startpos (point)) ;; look at all "=" from left to right, stopping at first one not nested in a ;; list or string (while searching (skip-chars-forward "^=" endpos) (if (= (point) endpos) (setq searching nil) (forward-char 1) (setq state (parse-partial-sexp startpos (point))) (if (and (zerop (car state)) ; not in a bracket (null (nth 3 state))) ; & not in a string (progn (setq searching nil) ; done searching in any case (setq found (not (or (eq (following-char) ?=) (memq (char-after (- (point) 2)) '(?< ?> ?!))))))))) (if (or (not found) ; not an assignment (looking-at "[ \t]*\\\\")) ; <=> (progn (goto-char startpos) (skip-chars-forward "^ \t\n"))) ;; if this is a continuation for a block opening ;; statement, add some extra offset. (+ (current-column) (if (fsharp-statement-opens-block-p) fsharp-continuation-offset 0) 1)))) (defun fsharp--compute-indentation-relative-to-previous (honor-block-close-p) "Indentation based on that of the statement that precedes us; use the first line of that statement to establish the base, in case the user forced a non-std indentation for the continuation lines (if any)" ;; skip back over blank & non-indenting comment lines note: ;; will skip a blank or non-indenting comment line that ;; happens to be a continuation line too. use fast Emacs 19 ;; function if it's there. (save-excursion (let ((bod (fsharp-point 'bod)) placeholder) (if (and (eq fsharp-honor-comment-indentation nil) (fboundp 'forward-comment)) (forward-comment (- (point-max))) (let ((prefix-re "//[ \t]*") done) (while (not done) (re-search-backward "^[ \t]*\\([^ \t\n]\\|//\\)" nil 'move) (setq done (or (bobp) (and (eq fsharp-honor-comment-indentation t) (save-excursion (back-to-indentation) (not (looking-at prefix-re)) )) (and (not (eq fsharp-honor-comment-indentation t)) (save-excursion (back-to-indentation) (and (not (looking-at prefix-re)) (or (looking-at "[^/]") (not (zerop (current-column)))))))))))) ;; if we landed inside a string, go to the beginning of that ;; string. this handles triple quoted, multi-line spanning ;; strings. (fsharp-goto-beginning-of-tqs (nth 3 (parse-partial-sexp bod (point)))) ;; now skip backward over continued lines (setq placeholder (point)) (fsharp-goto-initial-line) ;; we may *now* have landed in a TQS, so find the beginning of ;; this string. (fsharp-goto-beginning-of-tqs (save-excursion (nth 3 (parse-partial-sexp placeholder (point))))) (+ (current-indentation) (if (fsharp-statement-opens-block-p) fsharp-indent-offset (if (and honor-block-close-p (fsharp-statement-closes-block-p)) (- fsharp-indent-offset) 0)))))) (defun fsharp-newline-and-indent () "Strives to act like the Emacs `newline-and-indent'. This is just `strives to' because correct indentation can't be computed from scratch for Fsharp code. In general, deletes the whitespace before point, inserts a newline, and takes an educated guess as to how you want the new line indented." (interactive) (let ((ci (current-indentation))) (if (< ci (current-column)) ; if point beyond indentation (newline-and-indent) ;; else try to act like newline-and-indent "normally" acts (beginning-of-line) (insert-char ?\n 1) (move-to-column ci)))) (defun fsharp-compute-indentation (honor-block-close-p) "Compute Fsharp indentation. When HONOR-BLOCK-CLOSE-P is non-nil, statements such as `return', `raise', `break', `continue', and `pass' force one level of dedenting." (save-excursion (beginning-of-line) (let* ((bod (fsharp-point 'bod)) (pps (parse-partial-sexp bod (point))) (boipps (parse-partial-sexp bod (fsharp-point 'boi))) (open-bracket-pos (fsharp-nesting-level))) (cond ((and open-bracket-pos (eq (and (looking-back "[[:space:]\n\r]+" nil t) (match-beginning 0)) (1+ open-bracket-pos))) fsharp-indent-offset) ;; Continuation Lines ((fsharp-continuation-line-p) (if open-bracket-pos (fsharp--compute-indentation-open-bracket open-bracket-pos) (fsharp--compute-indentation-continuation-line))) ;; Previous line is a continuation line, use indentation of previous line ((fsharp--previous-line-continuation-line-p) (forward-line -1) (current-indentation)) ((or ;; Beginning of Buffer; not on a continuation line (bobp) ;; "Indenting Comment" (fsharp--indenting-comment-p)) (current-indentation)) ;; Final case includes things like pipe expressions (matches, left pipe) ;; and if/else blocks. ;; ;; else indentation based on that of the statement that ;; precedes us; use the first line of that statement to ;; establish the base, in case the user forced a non-std ;; indentation for the continuation lines (if any) (t (fsharp--compute-indentation-relative-to-previous honor-block-close-p)))))) (defun fsharp-guess-indent-offset (&optional global) "Guess a good value for, and change, `fsharp-indent-offset'. By default, make a buffer-local copy of `fsharp-indent-offset' with the new value, so that other Fsharp buffers are not affected. With \\[universal-argument] (programmatically, optional argument GLOBAL), change the global value of `fsharp-indent-offset'. This affects all Fsharp buffers (that don't have their own buffer-local copy), both those currently existing and those created later in the Emacs session. Some people use a different value for `fsharp-indent-offset' than you use. There's no excuse for such foolishness, but sometimes you have to deal with their ugly code anyway. This function examines the file and sets `fsharp-indent-offset' to what it thinks it was when they created the mess. Specifically, it searches forward from the statement containing point, looking for a line that opens a block of code. `fsharp-indent-offset' is set to the difference in indentation between that line and the Fsharp statement following it. If the search doesn't succeed going forward, it's tried again going backward." (interactive "P") ; raw prefix arg (let (new-value (start (point)) (restart (point)) (found nil) colon-indent) (fsharp-goto-initial-line) (while (not (or found (eobp))) (when (and (re-search-forward fsharp-block-opening-re nil 'move) (not (fsharp-in-literal-p restart))) (setq restart (point)) (fsharp-goto-initial-line) (if (fsharp-statement-opens-block-p) (setq found t) (goto-char restart)))) (unless found (goto-char start) (fsharp-goto-initial-line) (while (not (or found (bobp))) (setq found (and (re-search-backward fsharp-block-opening-re nil 'move) (or (fsharp-goto-initial-line) t) ; always true -- side effect (fsharp-statement-opens-block-p))))) (setq colon-indent (current-indentation) found (and found (zerop (fsharp-next-statement 1))) new-value (- (current-indentation) colon-indent)) (goto-char start) (if (not found) (message "Unable to determine default value for fsharp-indent-offset") (funcall (if global 'kill-local-variable 'make-local-variable) 'fsharp-indent-offset) (setq fsharp-indent-offset new-value) (or noninteractive (message "%s value of fsharp-indent-offset set to %d" (if global "Global" "Local") fsharp-indent-offset))))) (defun fsharp-comment-indent-function () "Fsharp version of `comment-indent-function'." ;; This is required when filladapt is turned off. Without it, when ;; filladapt is not used, comments which start in column zero ;; cascade one character to the right (save-excursion (beginning-of-line) (let ((eol (fsharp-point 'eol))) (and comment-start-skip (re-search-forward comment-start-skip eol t) (setq eol (match-beginning 0))) (goto-char eol) (skip-chars-backward " \t") (max comment-column (+ (current-column) (if (bolp) 0 1)))))) (defun fsharp-narrow-to-defun (&optional class) "Make text outside current defun invisible. The defun visible is the one that contains point or follows point. Optional CLASS is passed directly to `fsharp-beginning-of-def-or-class'." (interactive "P") (save-excursion (widen) (fsharp-end-of-def-or-class class) (let ((end (point))) (fsharp-beginning-of-def-or-class class) (narrow-to-region (point) end)))) (defun fsharp-shift-region (start end count) "Indent lines from START to END by COUNT spaces." (save-excursion (goto-char end) (beginning-of-line) (setq end (point)) (goto-char start) (beginning-of-line) (setq start (point)) (indent-rigidly start end count))) (defun fsharp-shift-region-left (start end &optional count) "Shift region of Fsharp code to the left. The lines from the line containing the start of the current region up to (but not including) the line containing the end of the region are shifted to the left, by `fsharp-indent-offset' columns. If a prefix argument is given, the region is instead shifted by that many columns. With no active region, dedent only the current line. You cannot dedent the region if any line is already at column zero." (interactive (let ((p (point)) (m (mark)) (arg current-prefix-arg)) (if m (list (min p m) (max p m) arg) (list p (save-excursion (forward-line 1) (point)) arg)))) ;; if any line is at column zero, don't shift the region (save-excursion (goto-char start) (while (< (point) end) (back-to-indentation) (if (and (zerop (current-column)) (not (looking-at "\\s *$"))) (error "Region is at left edge")) (forward-line 1))) (fsharp-shift-region start end (- (prefix-numeric-value (or count fsharp-indent-offset))))) (defun fsharp-shift-region-right (start end &optional count) "Shift region of Fsharp code to the right. The lines from the line containing the start of the current region up to (but not including) the line containing the end of the region are shifted to the right, by `fsharp-indent-offset' columns. If a prefix argument is given, the region is instead shifted by that many columns. With no active region, indent only the current line." (interactive (let ((p (point)) (m (mark)) (arg current-prefix-arg)) (if m (list (min p m) (max p m) arg) (list p (save-excursion (forward-line 1) (point)) arg)))) (fsharp-shift-region start end (prefix-numeric-value (or count fsharp-indent-offset)))) (defun fsharp-indent-region (start end &optional indent-offset) "Reindent a region of Fsharp code. The lines from the line containing the start of the current region up to (but not including) the line containing the end of the region are reindented. If the first line of the region has a non-whitespace character in the first column, the first line is left alone and the rest of the region is reindented with respect to it. Else the entire region is reindented with respect to the (closest code or indenting comment) statement immediately preceding the region. This is useful when code blocks are moved or yanked, when enclosing control structures are introduced or removed, or to reformat code using a new value for the indentation offset. If a numeric prefix argument is given, it will be used as the value of the indentation offset. Else the value of `fsharp-indent-offset' will be used. Warning: The region must be consistently indented before this function is called! This function does not compute proper indentation from scratch (that's impossible in Fsharp), it merely adjusts the existing indentation to be correct in context. Warning: This function really has no idea what to do with non-indenting comment lines, and shifts them as if they were indenting comment lines. Fixing this appears to require telepathy. Special cases: whitespace is deleted from blank lines; continuation lines are shifted by the same amount their initial line was shifted, in order to preserve their relative indentation with respect to their initial line; and comment lines beginning in column 1 are ignored." (interactive "*r\nP") ; region; raw prefix arg (save-excursion (goto-char end) (beginning-of-line) (setq end (point-marker)) (goto-char start) (beginning-of-line) (let ((fsharp-indent-offset (prefix-numeric-value (or indent-offset fsharp-indent-offset))) (indents '(-1)) ; stack of active indent levels (target-column 0) ; column to which to indent (base-shifted-by 0) ; amount last base line was shifted (indent-base (if (looking-at "[ \t\n]") (fsharp-compute-indentation t) 0)) ci) (while (< (point) end) (setq ci (current-indentation)) ;; figure out appropriate target column (cond ((or (looking-at "//") ; comment in column 1 (looking-at "[ \t]*$")) ; entirely blank (setq target-column 0)) ((fsharp-continuation-line-p) ; shift relative to base line (setq target-column (+ ci base-shifted-by))) (t ; new base line (if (> ci (car indents)) ; going deeper; push it (setq indents (cons ci indents)) ;; else we should have seen this indent before (setq indents (memq ci indents)) ; pop deeper indents (if (null indents) (error "Bad indentation in region, at line %d" (save-restriction (widen) (1+ (count-lines 1 (point))))))) (setq target-column (+ indent-base (* fsharp-indent-offset (- (length indents) 2)))) (setq base-shifted-by (- target-column ci)))) ;; shift as needed (if (/= ci target-column) (progn (delete-horizontal-space) (indent-to target-column))) (forward-line 1)))) (set-marker end nil)) ;;------------------------------ Motion and Mark ------------------------------;; (defun fsharp-previous-statement (count) "Go to the start of the COUNTth preceding Fsharp statement. By default, goes to the previous statement. If there is no such statement, goes to the first statement. Return count of statements left to move. `Statements' do not include blank, comment, or continuation lines." (interactive "p") ; numeric prefix arg (if (< count 0) (fsharp-next-statement (- count)) (fsharp-goto-initial-line) (let (start) (while (and (setq start (point)) ; always true -- side effect (> count 0) (zerop (forward-line -1)) (fsharp-goto-statement-at-or-above)) (setq count (1- count))) (if (> count 0) (goto-char start))) count)) (defun fsharp-next-statement (count) "Go to the start of next Fsharp statement. If the statement at point is the i'th Fsharp statement, goes to the start of statement i+COUNT. If there is no such statement, goes to the last statement. Returns count of statements left to move. `Statements' do not include blank, comment, or continuation lines." (interactive "p") ; numeric prefix arg (if (< count 0) (fsharp-previous-statement (- count)) (beginning-of-line) (let (start) (while (and (setq start (point)) ; always true -- side effect (> count 0) (fsharp-goto-statement-below)) (setq count (1- count))) (if (> count 0) (goto-char start))) count)) (defun fsharp-goto-block-up (&optional nomark) "Move up to start of current block. Go to the statement that starts the smallest enclosing block; roughly speaking, this will be the closest preceding statement that ends with a colon and is indented less than the statement you started on. If successful, also sets the mark to the starting point. `\\[fsharp-mark-block]' can be used afterward to mark the whole code block, if desired. If called from a program, the mark will not be set if optional argument NOMARK is not nil." (interactive) (let ((start (point)) (found nil) initial-indent) (fsharp-goto-initial-line) ;; if on and (mutually recursive bindings), blank or non-indenting comment line, use the preceding stmt (when (or (looking-at "[ \t]*\\($\\|//[^ \t\n]\\)") (looking-at-p "[ \t]*and[ \t]+")) (fsharp-goto-statement-at-or-above) (setq found (fsharp-statement-opens-block-p))) ;; search back for colon line indented less (setq initial-indent (current-indentation)) (if (zerop initial-indent) ;; force fast exit (goto-char (point-min))) (while (not (or found (bobp))) (setq found (and (re-search-backward fsharp-block-opening-re nil 'move) (or (fsharp-goto-initial-line) t) ; always true -- side effect (< (current-indentation) initial-indent) (fsharp-statement-opens-block-p)))) (if found (progn (or nomark (push-mark start)) (back-to-indentation)) (goto-char start) (error "Enclosing block not found")))) ;; The FIXME comment here is antique, and unexplained. My suspicion is that this ;; function was lifted from a Python mode (F# doesn't have the `def' keyword). ;; -- RMD 2019-10-20 ;;FIXME (defun fsharp-beginning-of-def-or-class (&optional class count) "Move point to start of `def' or `class'. Searches back for the closest preceding `def'. If you supply a prefix arg, looks for a `class' instead. The docs below assume the `def' case; just substitute `class' for `def' for the other case. Programmatically, if CLASS is `either', then moves to either `class' or `def'. When second optional argument is given programmatically, move to the COUNTth start of `def'. If point is in a `def' statement already, and after the `d', simply moves point to the start of the statement. Otherwise (i.e. when point is not in a `def' statement, or at or before the `d' of a `def' statement), searches for the closest preceding `def' statement, and leaves point at its start. If no such statement can be found, leaves point at the start of the buffer. Returns t iff a `def' statement is found by these rules. Note that doing this command repeatedly will take you closer to the start of the buffer each time. To mark the current `def', see `\\[fsharp-mark-def-or-class]'." (interactive "P") ; raw prefix arg (setq count (or count 1)) (let ((at-or-before-p (<= (current-column) (current-indentation))) (start-of-line (goto-char (fsharp-point 'bol))) (start-of-stmt (goto-char (fsharp-point 'bos))) (start-re (cond ((eq class 'either) "^[ \t]*\\(type\\|let\\)\\>") (class "^[ \t]*type\\>") (t "^[ \t]*let\\>")))) ;; searching backward (if (and (< 0 count) (or (/= start-of-stmt start-of-line) (not at-or-before-p))) (end-of-line)) ;; search forward (if (and (> 0 count) (zerop (current-column)) (looking-at start-re)) (end-of-line)) (if (re-search-backward start-re nil 'move count) (goto-char (match-beginning 0))))) ;; Backwards compatibility (defalias 'beginning-of-fsharp-def-or-class 'fsharp-beginning-of-def-or-class) (defun fsharp-end-of-def-or-class (&optional class count) "Move point beyond end of `def' or `class' body. By default, looks for an appropriate `def'. If you supply a prefix arg, looks for a `class' instead. The docs below assume the `def' case; just substitute `class' for `def' for the other case. Programmatically, if CLASS is `either', then moves to either `class' or `def'. When second optional argument is given programmatically, move to the COUNTth end of `def'. If point is in a `def' statement already, this is the `def' we use. Else, if the `def' found by `\\[fsharp-beginning-of-def-or-class]' contains the statement you started on, that's the `def' we use. Otherwise, we search forward for the closest following `def', and use that. If a `def' can be found by these rules, point is moved to the start of the line immediately following the `def' block, and the position of the start of the `def' is returned. Else point is moved to the end of the buffer, and nil is returned. Note that doing this command repeatedly will take you closer to the end of the buffer each time. To mark the current `def', see `\\[fsharp-mark-def-or-class]'." (interactive "P") ; raw prefix arg (if (and count (/= count 1)) (fsharp-beginning-of-def-or-class (- 1 count))) (let ((start (progn (fsharp-goto-initial-line) (point))) (which (cond ((eq class 'either) "\\(type\\|let\\)") (class "type") (t "let"))) (state 'not-found)) ;; move point to start of appropriate def/class (if (looking-at (concat "[ \t]*" which "\\>")) ; already on one (setq state 'at-beginning) ;; else see if fsharp-beginning-of-def-or-class hits container (if (and (fsharp-beginning-of-def-or-class class) (progn (fsharp-goto-beyond-block) (> (point) start))) (setq state 'at-end) ;; else search forward (goto-char start) (if (re-search-forward (concat "^[ \t]*" which "\\>") nil 'move) (progn (setq state 'at-beginning) (beginning-of-line))))) (cond ((eq state 'at-beginning) (fsharp-goto-beyond-block) t) ((eq state 'at-end) t) ((eq state 'not-found) nil) (t (error "Internal error in `fsharp-end-of-def-or-class'"))))) ;; Helper functions ;; TODO: we only return the parse state if we are *not* inside a string. This ;; doesn't make a lot of sense; checking for being inside a triple-quoted string ;; is a thing we frequently need to do. Need to figure out a reason and/or ;; abstract over the top of this. (defun fsharp-parse-state () "Return the parse state at point (see `parse-partial-sexp' docs)." (save-excursion (let ((here (point)) pps done) (while (not done) ;; back up to the first preceding line (if any; else start of ;; buffer) that begins with a popular Fsharp keyword, or a ;; non- whitespace and non-comment character. These are good ;; places to start parsing to see whether where we started is ;; at a non-zero nesting level. It may be slow for people who ;; write huge code blocks or huge lists ... tough beans. (re-search-backward fsharp-parse-state-re nil 'move) (beginning-of-line) ;; In XEmacs, we have a much better way to test for whether ;; we're in a triple-quoted string or not. Emacs does not ;; have this built-in function, which is its loss because ;; without scanning from the beginning of the buffer, there's ;; no accurate way to determine this otherwise. ;; ;; NOTE[@gastove|2019-10-21]: it is not at *all* clear what this comment is on ;; about. Emacs has all the functions used in this function. (save-excursion (setq pps (parse-partial-sexp (point) here))) ;; make sure we don't land inside a triple-quoted string (setq done (or (not (nth 3 pps)) (bobp))) ;; Just go ahead and short circuit the test back to the ;; beginning of the buffer. This will be slow, but not ;; nearly as slow as looping through many ;; re-search-backwards. (if (not done) (goto-char (point-min)))) pps))) (defun fsharp-nesting-level () "Return the buffer position of the opening character of the current enclosing pair. If nesting level is zero, return nil. At time of writing, enclosing pair can be [], {} or (), but not quotes (single or triple) or <>. Note that registering [] implicitly also registers [||], though the pipes are ignored." (let ((status (fsharp-parse-state))) (if (zerop (car status)) nil ; not in a nest (car (cdr status))))) ; char of open bracket ;; NOTE[gastove|2019-10-25] this function baffles me. A triple-quoted string is, ;; definitionally, always delimited by *triple quotes*. I suspect this function ;; of being something more akin to, "go to beginning of opening of pair", or ;; just "go to delimiter." (defun fsharp-goto-beginning-of-tqs (delim) "Go to the beginning of the triple quoted string we find ourselves in. DELIM is the TQS string delimiter character we're searching backwards for." (let ((skip (and delim (make-string 1 delim))) (continue t)) (when skip (save-excursion (while continue (search-backward skip nil t) (setq continue (and (not (bobp)) (= (char-before) ?\\)))) (if (and (= (char-before) delim) (= (char-before (1- (point))) delim)) (setq skip (make-string 3 delim)))) ;; we're looking at a triple-quoted string (search-backward skip nil t)))) (defun fsharp-goto-initial-line () "Go to the initial line of the current statement. Usually this is the line we're on, but if we're on the 2nd or following lines of a continuation block, we need to go up to the first line of the block." ;; Tricky: We want to avoid quadratic-time behavior for long ;; continued blocks, whether of the backslash or open-bracket ;; varieties, or a mix of the two. The following manages to do that ;; in the usual cases. ;; ;; Also, if we're sitting inside a triple quoted string, this will ;; drop us at the line that begins the string. (let (open-bracket-pos) (while (fsharp-continuation-line-p) (beginning-of-line) (if (fsharp--hanging-operator-continuation-line-p) (while (fsharp--hanging-operator-continuation-line-p) (forward-line -1)) ;; else zip out of nested brackets/braces/parens (while (setq open-bracket-pos (fsharp-nesting-level)) (goto-char open-bracket-pos))))) (beginning-of-line)) ;; TODO[gastove|2019-10-31] This is completely broken. I'm not totally sure why ;; or how, but it simply doesn't do the thing it says on the tin. (defun fsharp-goto-beyond-final-line () "Go to the point just beyond the final line of the current expression. Usually this is the start of the next line, but if this is a multi-line expression we need to skip over the continuation lines." ;; TODO[gastove|2019-10-30] This works on triple-quoted strings that start on ;; their own line, but not if they are opened on the same line as a let. (if (looking-at (concat "[ \t]*\\(" fsharp-stringlit-re "\\)")) (goto-char (match-end 0))) ;; (forward-line 1) (let (state) ;; I think this first predicate is the problem -- "continuation lines", as ;; defined by that function, are only lines with hanging arithmetic ;; operators *or* lines inside certain pairs (things like data structures ;; and computation expressions). This fully doesn't account for ;; continuations using pipes. (while (and (fsharp-continuation-line-p) (not (eobp))) ;; skip over hanging operator lines (while (and (fsharp--hanging-operator-continuation-line-p) (not (eobp))) (forward-line 1)) ;; if in nest, zip to the end of the nest (setq state (fsharp-parse-state)) (when (and (not (zerop (car state))) (not (eobp))) (progn (parse-partial-sexp (point) (point-max) 0 nil state) (forward-line 1)))))) (defun fsharp-goto-beyond-block () "Go to point just beyond the final line of block begun by the current line. This is the same as where `fsharp-goto-beyond-final-line' goes unless we're on colon line, in which case we go to the end of the block. Assumes point is at the beginning of the line." (if (fsharp-statement-opens-block-p) (fsharp-mark-block nil 'just-move) (fsharp-goto-beyond-final-line))) (defun fsharp-goto-statement-at-or-above () "Go to the start of the first statement at or preceding point. Return t if there is such a statement, otherwise nil. `Statement' does not include blank lines, comments, or continuation lines." (fsharp-goto-initial-line) (if (looking-at fsharp-blank-or-comment-re) ;; skip back over blank & comment lines ;; note: will skip a blank or comment line that happens to be ;; a continuation line too (if (re-search-backward "^[ \t]*\\([^ \t\n]\\|//\\)" nil t) (progn (fsharp-goto-initial-line) t) nil) t)) (defun fsharp-goto-statement-below () "Go to start of the first statement following the statement containing point. Return t if there is such a statement, otherwise nil. `Statement' does not include blank lines, comments, or continuation lines." (beginning-of-line) (let ((start (point))) (fsharp-goto-beyond-final-line) (while (and (or (looking-at fsharp-blank-or-comment-re) (fsharp-in-literal-p)) (not (eobp))) (forward-line 1)) (if (eobp) (progn (goto-char start) nil) t))) (defun fsharp-go-up-tree-to-keyword (key) "Go to begining of statement starting with KEY, at or preceding point. KEY is a regular expression describing a Fsharp keyword. Skip blank lines and non-indenting comments. If the statement found starts with KEY, then stop, otherwise go back to first enclosing block starting with KEY. If successful, leave point at the start of the KEY line and return t. Otherwise, leave point at an undefined place and return nil." ;; skip blanks and non-indenting // (fsharp-goto-initial-line) (while (and (looking-at "[ \t]*\\($\\|//[^ \t\n]\\)") (zerop (forward-line -1))) ; go back nil) (fsharp-goto-initial-line) (let* ((re (concat "[ \t]*" key "\\>")) (case-fold-search nil) ; let* so looking-at sees this (found (looking-at re)) (dead nil)) (while (not (or found dead)) (condition-case nil ; in case no enclosing block (fsharp-goto-block-up 'no-mark) (error (setq dead t))) (or dead (setq found (looking-at re)))) (beginning-of-line) found)) (defun fsharp-suck-up-leading-text () "Return string in buffer from start of indentation to end of line. Prefix with \"...\" if leading whitespace was skipped." (save-excursion (back-to-indentation) (concat (if (bolp) "" "...") (buffer-substring (point) (progn (end-of-line) (point)))))) (defun fsharp-suck-up-first-keyword () "Return first keyword on the line as a Lisp symbol. `Keyword' is defined (essentially) as the regular expression ([a-z]+). Returns nil if none was found." (let ((case-fold-search nil)) (if (looking-at "[ \t]*\\([a-z]+\\)\\>") (intern (buffer-substring (match-beginning 1) (match-end 1))) nil))) (defun fsharp-current-defun () "Fsharp value for `add-log-current-defun-function'. This tells add-log.el how to find the current function/method/variable." (save-excursion ;; Move back to start of the current statement. (fsharp-goto-initial-line) (back-to-indentation) (while (and (or (looking-at fsharp-blank-or-comment-re) (fsharp-in-literal-p)) (not (eq (point-at-bol) (point-min)))) (backward-to-indentation 1)) (fsharp-goto-initial-line) (let ((scopes "") (sep "") dead assignment) ;; Check for an assignment. If this assignment exists inside a ;; def, it will be overwritten inside the while loop. If it ;; exists at top lever or inside a class, it will be preserved. (when (looking-at "[ \t]*\\([a-zA-Z0-9_]+\\)[ \t]*=") (setq scopes (buffer-substring (match-beginning 1) (match-end 1))) (setq assignment t) (setq sep ".")) ;; Prepend the name of each outer socpe (def or class). (while (not dead) (if (and (fsharp-go-up-tree-to-keyword "\\(class\\|def\\)") (looking-at "[ \t]*\\(class\\|def\\)[ \t]*\\([a-zA-Z0-9_]+\\)[ \t]*")) (let ((name (buffer-substring (match-beginning 2) (match-end 2)))) (if (and assignment (looking-at "[ \t]*def")) (setq scopes name) (setq scopes (concat name sep scopes)) (setq sep ".")))) (setq assignment nil) (condition-case nil ; Terminate nicely at top level. (fsharp-goto-block-up 'no-mark) (error (setq dead t)))) (if (string= scopes "") nil scopes)))) (defun fsharp-beginning-of-block () "Move point to the beginning of the current top-level block" (interactive) (let ((prev (point))) (condition-case nil (while (progn (fsharp-goto-block-up 'no-mark) (< (point) prev)) (setq prev (point))) (error (while (fsharp-continuation-line-p) (forward-line -1))))) (beginning-of-line)) (defun fsharp-end-of-block () "Move point to the end of the current top-level block" (interactive) (forward-line 1) (if (not (eobp)) (progn (beginning-of-line) (condition-case nil (progn (re-search-forward "^[a-zA-Z#0-9([]") (while (fsharp-continuation-line-p) (forward-line 1)) (forward-line -1)) (error (progn (goto-char (point-max))))) (end-of-line) (when (looking-at-p "\n[ \t]*and[ \t]+") (forward-line 1) (fsharp-end-of-block))) (goto-char (point-max)))) (defun fsharp-mark-phrase () "Mark current phrase" (interactive) (fsharp-beginning-of-block) (push-mark (point)) (fsharp-end-of-block) (exchange-point-and-mark)) (defun fsharp-mark-block (&optional extend just-move) "Mark following block of lines. With prefix arg, mark structure. Easier to use than explain. It sets the region to an `interesting' block of succeeding lines. If point is on a blank line, it goes down to the next non-blank line. That will be the start of the region. The end of the region depends on the kind of line at the start: - If a comment, the region will include all succeeding comment lines up to (but not including) the next non-comment line (if any). - Else if a prefix arg is given, and the line begins one of these structures: if elif else try except finally for while def class the region will be set to the body of the structure, including following blocks that `belong' to it, but excluding trailing blank and comment lines. E.g., if on a `try' statement, the `try' block and all (if any) of the following `except' and `finally' blocks that belong to the `try' structure will be in the region. Ditto for if/elif/else, for/else and while/else structures, and (a bit degenerate, since they're always one-block structures) def and class blocks. - Else if no prefix argument is given, and the line begins a Fsharp block (see list above), and the block is not a `one-liner' (i.e., the statement ends with a colon, not with code), the region will include all succeeding lines up to (but not including) the next code statement (if any) that's indented no more than the starting line, except that trailing blank and comment lines are excluded. E.g., if the starting line begins a multi-statement `def' structure, the region will be set to the full function definition, but without any trailing `noise' lines. - Else the region will include all succeeding lines up to (but not including) the next blank line, or code or indenting-comment line indented strictly less than the starting line. Trailing indenting comment lines are included in this case, but not trailing blank lines. A msg identifying the location of the mark is displayed in the echo area; or do `\\[exchange-point-and-mark]' to flip down to the end. If called from a program, optional argument EXTEND plays the role of the prefix arg, and if optional argument JUST-MOVE is not nil, just moves to the end of the block (& does not set mark or display a msg)." (interactive "P") ; raw prefix arg (fsharp-goto-initial-line) ;; skip over blank lines (while (and (looking-at "[ \t]*$") ; while blank line (not (eobp))) ; & somewhere to go (forward-line 1)) (if (eobp) (error "Hit end of buffer without finding a non-blank stmt")) (let ((initial-pos (point)) (initial-indent (current-indentation)) last-pos ; position of last stmt in region (followers '((if elif else) (elif elif else) (else) (try except finally) (except except) (finally) (for else) (while else) (def) (class) ) ) first-symbol next-symbol) (cond ;; if comment line, suck up the following comment lines ((looking-at "[ \t]*//") (re-search-forward "^[ \t]*\\([^ \t]\\|//\\)" nil 'move) ; look for non-comment (re-search-backward "^[ \t]*//") ; and back to last comment in block (setq last-pos (point))) ;; else if line is a block line and EXTEND given, suck up ;; the whole structure ((and extend (setq first-symbol (fsharp-suck-up-first-keyword) ) (assq first-symbol followers)) (while (and (or (fsharp-goto-beyond-block) t) ; side effect (forward-line -1) ; side effect (setq last-pos (point)) ; side effect (fsharp-goto-statement-below) (= (current-indentation) initial-indent) (setq next-symbol (fsharp-suck-up-first-keyword)) (memq next-symbol (cdr (assq first-symbol followers)))) (setq first-symbol next-symbol))) ;; else if line *opens* a block, search for next stmt indented <= ((fsharp-statement-opens-block-p) (while (and (setq last-pos (point)) ; always true -- side effect (fsharp-goto-statement-below) (> (current-indentation) initial-indent)))) ;; else plain code line; stop at next blank line, or stmt or ;; indenting comment line indented < (t (while (and (setq last-pos (point)) ; always true -- side effect (or (fsharp-goto-beyond-final-line) t) (not (looking-at "[ \t]*$")) ; stop at blank line (or (>= (current-indentation) initial-indent) (looking-at "[ \t]*//[^ \t\n]"))) ; ignore non-indenting // nil))) ;; skip to end of last stmt (goto-char last-pos) (fsharp-goto-beyond-final-line) ;; set mark & display (if just-move () ; just return (push-mark (point) 'no-msg) (forward-line -1) (message "Mark set after: %s" (fsharp-suck-up-leading-text)) (goto-char initial-pos)))) (defun fsharp-mark-def-or-class (&optional class) "Set region to body of def (or class, with prefix arg) enclosing point. Pushes the current mark, then point, on the mark ring (all language modes do this, but although it's handy it's never documented ...). In most Emacs language modes, this function bears at least a hallucinogenic resemblance to `\\[fsharp-end-of-def-or-class]' and `\\[fsharp-beginning-of-def-or-class]'. And in earlier versions of Fsharp mode, all 3 were tightly connected. Turned out that was more confusing than useful: the `goto start' and `goto end' commands are usually used to search through a file, and people expect them to act a lot like `search backward' and `search forward' string-search commands. But because Fsharp `def' and `class' can nest to arbitrary levels, finding the smallest def containing point cannot be done via a simple backward search: the def containing point may not be the closest preceding def, or even the closest preceding def that's indented less. The fancy algorithm required is appropriate for the usual uses of this `mark' command, but not for the `goto' variations. So the def marked by this command may not be the one either of the `goto' commands find: If point is on a blank or non-indenting comment line, moves back to start of the closest preceding code statement or indenting comment line. If this is a `def' statement, that's the def we use. Else searches for the smallest enclosing `def' block and uses that. Else signals an error. When an enclosing def is found: The mark is left immediately beyond the last line of the def block. Point is left at the start of the def, except that: if the def is preceded by a number of comment lines followed by (at most) one optional blank line, point is left at the start of the comments; else if the def is preceded by a blank line, point is left at its start. The intent is to mark the containing def/class and its associated documentation, to make moving and duplicating functions and classes pleasant." (interactive "P") ; raw prefix arg (let ((start (point)) (which (cond ((eq class 'either) "\\(type\\|let\\)") (class "type") (t "let")))) (push-mark start) (if (not (fsharp-go-up-tree-to-keyword which)) (progn (goto-char start) (error "Enclosing %s not found" (if (eq class 'either) "def or class" which))) ;; else enclosing def/class found (setq start (point)) (fsharp-goto-beyond-block) (push-mark (point)) (goto-char start) (if (zerop (forward-line -1)) ; if there is a preceding line (progn (if (looking-at "[ \t]*$") ; it's blank (setq start (point)) ; so reset start point (goto-char start)) ; else try again (if (zerop (forward-line -1)) (if (looking-at "[ \t]*//") ; a comment ;; look back for non-comment line ;; tricky: note that the regexp matches a blank ;; line, cuz \n is in the 2nd character class (and (re-search-backward "^[ \t]*\\([^ \t]\\|//\\)" nil 'move) (forward-line 1)) ;; no comment, so go back (goto-char start))))))) (exchange-point-and-mark)) ;;------------------------------- SMIE Configs -------------------------------;; (defconst fsharp-smie-grammar ;; SMIE grammar follow the refernce of SML-mode. (smie-prec2->grammar (smie-merge-prec2s (smie-bnf->prec2 '((id) (expr ("while" expr "do" expr) ("if" expr "then" expr "else" expr) ("for" expr "in" expr "do" expr) ("for" expr "to" expr "do" expr) ("try" expr "with" branches) ("try" expr "finally" expr) ("match" expr "with" branches) ("type" expr "=" branches) ("begin" exprs "end") ("[" exprs "]") ("[|" exprs "|]") ("{" exprs "}") ("<@" exprs "@>") ("<@@" exprs "@@>") ("let" sexp "=" expr) ("fun" expr "->" expr)) (sexp ("rec") (sexp ":" type) (sexp "||" sexp) (sexp "&&" sexp) ("(" exprs ")")) (exprs (exprs ";" exprs) (exprs "," exprs) (expr)) (type (type "->" type) (type "*" type)) (branches (branches "|" branches)) (decls (sexp "=" expr)) (toplevel (decls) (expr) (toplevel ";;" toplevel))) '((assoc "|")) '((assoc "->") (assoc "*")) '((assoc "let" "fun" "type" "open" "->")) '((assoc "let") (assoc "=")) '((assoc "[" "]" "[|" "|]" "{" "}")) '((assoc "<@" "@>")) '((assoc "<@@" "@@>")) '((assoc "&&") (assoc "||") (noassoc ":")) '((assoc ";") (assoc ",")) '((assoc ";;"))) (smie-precs->prec2 '((nonassoc (">" ">=" "<>" "<" "<=" "=")) (assoc "::") (assoc "+" "-" "^") (assoc "/" "*" "%"))))) ) (defun fsharp-smie-rules (kind token) (pcase (cons kind token) (`(:elem . basic) fsharp-indent-offset) (`(:after . "do") fsharp-indent-offset) (`(:after . "then") fsharp-indent-offset) (`(:after . "else") fsharp-indent-offset) (`(:after . "try") fsharp-indent-offset) (`(:after . "with") fsharp-indent-offset) (`(:after . "finally") fsharp-indent-offset) (`(:after . "in") 0) (`(:after . ,(or `"[" `"]" `"[|" `"|]")) fsharp-indent-offset) (`(,_ . ,(or `";" `",")) (if (smie-rule-parent-p "begin") 0 (smie-rule-separator kind))) (`(:after . "=") fsharp-indent-offset) (`(:after . ";;") (smie-rule-separator kind)) (`(:before . ";;") (if (smie-rule-bolp) 0)) )) (defun fsharp-mode-indent-smie-setup () (smie-setup fsharp-smie-grammar #'fsharp-smie-rules)) (provide 'fsharp-mode-structure) ;;; fsharp-mode-structure.el ends here ================================================ FILE: fsharp-mode-util.el ================================================ ;;; fsharp-mode-util.el --- utility functions -*- lexical-binding: t -*- ;; Copyright (C) 2015 Robin Neatherway ;; Author: 2015 Robin Neatherway ;; Maintainer: Robin Neatherway ;; Keywords: languages ;; This file is not part of GNU Emacs. ;; This file is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; This file is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. (require 'cl-lib) (defvar fsharp-ac-using-mono (cl-case system-type ((windows-nt cygwin msdos) nil) (otherwise t)) "Whether the .NET runtime in use is mono. Defaults to nil for Microsoft platforms (including Cygwin), t for all *nix.") (defun fsharp-mode--program-files-x86 () (file-name-as-directory (or (getenv "ProgramFiles(x86)") (getenv "ProgramFiles") "C:\\Program Files (x86)"))) (defun fsharp-mode--vs2017-msbuild-find (exe) "Return EXE absolute path for Visual Studio 2017, if existent, else nil." (let ((candidates (mapcar (lambda (edition) (concat (fsharp-mode--program-files-x86) edition "msbuild/15.0/bin/" exe)) '("Enterprise/" "Professional/" "Community/" "BuildTools/")))) (cl-find-if (lambda (exe) (file-executable-p exe)) candidates))) (defun fsharp-mode--msbuild-find (exe) (if fsharp-ac-using-mono (executable-find exe) (let* ((searchdirs (mapcar (lambda (ver) (concat (fsharp-mode--program-files-x86) "MSBuild/" ver "/Bin")) '("14.0" "13.0" "12.0"))) (exec-path (append searchdirs exec-path))) (or (fsharp-mode--vs2017-msbuild-find exe) (executable-find exe))))) (defun fsharp-mode--executable-find (exe) (if fsharp-ac-using-mono (executable-find exe) (let* ((searchdirs (mapcar (lambda (ver) (concat (fsharp-mode--program-files-x86) "Microsoft SDKs/F#/" ver "/Framework/v4.0")) '("10.1" "4.0" "3.1" "3.0"))) (exec-path (append searchdirs exec-path))) (executable-find exe)))) (provide 'fsharp-mode-util) ;;; fsharp-mode-util.el ends here ================================================ FILE: fsharp-mode.el ================================================ ;;; fsharp-mode.el --- Support for the F# programming language ;; Copyright (C) 1997 INRIA ;; Author: 1993-1997 Xavier Leroy, Jacques Garrigue and Ian T Zimmerman ;; 2010-2011 Laurent Le Brun ;; 2012-2014 Robin Neatherway ;; 2017-2023 Jürgen Hötzel ;; Maintainer: Jürgen Hötzel ;; Package-Requires: ((emacs "25")) ;; Keywords: languages ;; Version: 1.11-snapshot ;; This file is not part of GNU Emacs. ;; This file is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; This file is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Code: (require 'fsharp-mode-structure) (require 'inf-fsharp-mode) (require 'fsharp-mode-util) (require 'compile) (require 'project) (require 'subr-x) (require 'seq) (defgroup fsharp nil "Support for the Fsharp programming language, " :group 'languages :prefix "fsharp-") ;;; Compilation (defvar fsharp-compile-command (seq-some #'fsharp-mode--executable-find '("fsharpc" "fsc")) "The program used to compile F# source files.") (defvar fsharp-build-command (seq-some #'fsharp-mode--msbuild-find '("msbuild" "xbuild")) "The command used to build F# projects and solutions.") ;;; ---------------------------------------------------------------------------- (defvar fsharp-shell-active nil "Non nil when a subshell is running.") (defvar running-xemacs (string-match "XEmacs" emacs-version) "Non-nil if we are running in the XEmacs environment.") (defvar fsharp-mode-map nil "Keymap used in fsharp mode.") (unless fsharp-mode-map (setq fsharp-mode-map (make-sparse-keymap)) (if running-xemacs (define-key fsharp-mode-map 'backspace 'backward-delete-char-untabify) (define-key fsharp-mode-map "\177" 'backward-delete-char-untabify)) ;; F# bindings (define-key fsharp-mode-map "\C-c\C-a" 'fsharp-find-alternate-file) (define-key fsharp-mode-map "\C-c\C-c" 'compile) (define-key fsharp-mode-map "\M-\C-x" 'fsharp-eval-phrase) (define-key fsharp-mode-map "\C-c\C-e" 'fsharp-eval-phrase) (define-key fsharp-mode-map "\C-x\C-e" 'fsharp-eval-phrase) (define-key fsharp-mode-map "\C-c\C-r" 'fsharp-eval-region) (define-key fsharp-mode-map "\C-c\C-f" 'fsharp-load-buffer-file) (define-key fsharp-mode-map "\C-c\C-s" 'fsharp-show-subshell) (define-key fsharp-mode-map "\M-\C-h" 'fsharp-mark-phrase) (define-key fsharp-mode-map (kbd "M-n") 'next-error) (define-key fsharp-mode-map (kbd "M-p") 'previous-error) (define-key fsharp-mode-map "\C-c<" 'fsharp-shift-region-left) (define-key fsharp-mode-map "\C-c>" 'fsharp-shift-region-right) (define-key fsharp-mode-map "\C-m" 'fsharp-newline-and-indent) (define-key fsharp-mode-map "\C-c:" 'fsharp-guess-indent-offset) (define-key fsharp-mode-map (kbd "C-c ") 'fsharp-goto-block-up) (unless running-xemacs (let ((map (make-sparse-keymap "fsharp")) (forms (make-sparse-keymap "Forms"))) (define-key fsharp-mode-map [menu-bar] (make-sparse-keymap)) (define-key fsharp-mode-map [menu-bar fsharp] (cons "F#" map)) (define-key map [goto-block-up] '("Goto block up" . fsharp-goto-block-up)) (define-key map [mark-phrase] '("Mark phrase" . fsharp-mark-phrase)) (define-key map [shift-left] '("Shift region to right" . fsharp-shift-region-right)) (define-key map [shift-right] '("Shift region to left" . fsharp-shift-region-left)) (define-key map [separator-2] '("---")) ;; others (define-key map [compile] '("Compile..." . compile)) (define-key map [switch-view] '("Switch view" . fsharp-find-alternate-file)) (define-key map [separator-1] '("--")) (define-key map [show-subshell] '("Show subshell" . fsharp-show-subshell)) (define-key map [eval-region] '("Eval region" . fsharp-eval-region)) (define-key map [eval-phrase] '("Eval phrase" . fsharp-eval-phrase))))) ;;;###autoload (progn (add-to-list 'auto-mode-alist '("\\.fs[iylx]?\\'" . fsharp-mode)) (add-to-list 'auto-mode-alist '("\\.fsproj\\'" . nxml-mode))) (defvar fsharp-mode-syntax-table nil "Syntax table in use in fsharp mode buffers.") (unless fsharp-mode-syntax-table (setq fsharp-mode-syntax-table (make-syntax-table)) ; backslash is an escape sequence (modify-syntax-entry ?\\ "\\" fsharp-mode-syntax-table) ; ( is first character of comment start (modify-syntax-entry ?\( "()1n" fsharp-mode-syntax-table) ; * is second character of comment start, ; and first character of comment end (modify-syntax-entry ?* ". 23n" fsharp-mode-syntax-table) ; ) is last character of comment end (modify-syntax-entry ?\) ")(4n" fsharp-mode-syntax-table) ; // is the beginning of a comment "b" (modify-syntax-entry ?/ ". 12b" fsharp-mode-syntax-table) ; // \n is the end of a comment "b" (modify-syntax-entry ?\n "> b" fsharp-mode-syntax-table) ; quote and underscore are part of symbols ; so are # and ! as they can form part of types/preprocessor ; directives and also keywords (modify-syntax-entry ?' "_" fsharp-mode-syntax-table) (modify-syntax-entry ?_ "_" fsharp-mode-syntax-table) (modify-syntax-entry ?# "_" fsharp-mode-syntax-table) (modify-syntax-entry ?! "_" fsharp-mode-syntax-table) ; ISO-latin accented letters and EUC kanjis are part of words (let ((i 160)) (while (< i 256) (modify-syntax-entry i "w" fsharp-mode-syntax-table) (setq i (1+ i))))) ;; Other internal variables (defvar fsharp-last-noncomment-pos nil "Caches last buffer position determined not inside a fsharp comment.") (make-variable-buffer-local 'fsharp-last-noncomment-pos) ;; last-noncomment-pos can be a simple position, because we nil it ;; anyway whenever buffer changes upstream. last-comment-start and -end ;; have to be markers, because we preserve them when the changes' end ;; doesn't overlap with the comment's start. (defvar fsharp-last-comment-start nil "A marker caching last determined fsharp comment start.") (make-variable-buffer-local 'fsharp-last-comment-start) (defvar fsharp-last-comment-end nil "A marker caching last determined fsharp comment end.") (make-variable-buffer-local 'fsharp-last-comment-end) (defvar fsharp-mode-hook nil "Hook for fsharp-mode") (defcustom fsharp-autosave-on-file-load nil "Determine if buffer should be automatically saved on `fsharp-load-buffer-file'. If set to t, the buffer will always be saved, silently." :type 'boolean :group 'fsharp-mode) ;;;###autoload (define-derived-mode fsharp-mode prog-mode "fsharp" :syntax-table fsharp-mode-syntax-table "Major mode for editing fsharp code. \\{fsharp-mode-map}" (require 'fsharp-mode-font) (fsharp-mode-indent-smie-setup) (use-local-map fsharp-mode-map) (mapc 'make-local-variable '(paragraph-start require-final-newline paragraph-separate paragraph-ignore-fill-prefix comment-start comment-end comment-column comment-start-skip comment-indent-function adaptive-fill-regexp parse-sexp-ignore-comments indent-region-function indent-line-function add-log-current-defun-function underline-minimum-offset compile-command syntax-propertize-function)) (setq local-abbrev-table fsharp-mode-abbrev-table paragraph-start (concat "^$\\|" page-delimiter) paragraph-separate paragraph-start require-final-newline 'visit-save indent-tabs-mode nil comment-start "//" comment-end "" comment-column 40 comment-start-skip "///* *" adaptive-fill-regexp "[ \t]*\\(//+[ \t]*\\)*" comment-indent-function 'fsharp-comment-indent-function indent-region-function 'fsharp-indent-region indent-line-function 'fsharp-indent-line underline-minimum-offset 4 paragraph-ignore-fill-prefix t add-log-current-defun-function 'fsharp-current-defun fsharp-last-noncomment-pos nil fsharp-last-comment-start (make-marker) fsharp-last-comment-end (make-marker)) ; Syntax highlighting (setq font-lock-defaults '(fsharp-font-lock-keywords)) (setq syntax-propertize-function 'fsharp--syntax-propertize-function) ; Some reasonable defaults for company mode ;; In Emacs 24.4 onwards, tell electric-indent-mode that fsharp-mode ;; has no deterministic indentation. (when (boundp 'electric-indent-inhibit) (setq electric-indent-inhibit t)) (when-let ((file (buffer-file-name))) (setq compile-command (fsharp-mode-choose-compile-command file)))) (defun fsharp-mode-choose-compile-command (file) "Format an appropriate compilation command, depending on several factors: 1. The presence of a makefile 2. The presence of a .sln or .fsproj 3. The file's type. " (let* ((fname (file-name-nondirectory file)) (dname (file-name-directory file)) (ext (file-name-extension file)) (proj (fsharp-mode/find-sln-or-fsproj file)) (makefile (or (file-exists-p (concat dname "/Makefile")) (file-exists-p (concat dname "/makefile"))))) (cond (makefile compile-command) ((and fsharp-build-command proj) (combine-and-quote-strings `(,fsharp-build-command "/nologo" ,proj))) ((and fsharp-compile-command (member ext '("fs" "fsx"))) (combine-and-quote-strings `(,fsharp-compile-command "--nologo" ,file))) ((equal ext "fsl") (combine-and-quote-strings (list "fslex" file))) ((equal ext "fsy") (combine-and-quote-strings (list "fsyacc" file))) (t compile-command)))) (defun fsharp-find-alternate-file () (interactive) (let ((name (buffer-file-name))) (if (string-match "^\\(.*\\)\\.\\(fs\\|fsi\\)$" name) (find-file (concat (fsharp-match-string 1 name) (if (string= "fs" (fsharp-match-string 2 name)) ".fsi" ".fs")))))) ;;; Subshell support (defun fsharp-eval-region (start end) "Send the current region to the inferior fsharp process." (interactive"r") (require 'inf-fsharp-mode) (inferior-fsharp-eval-region start end)) (defun fsharp-eval-phrase () "Send current phrase to the interactive mode" (interactive) (save-excursion (let ((p1) (p2)) (fsharp-beginning-of-block) (setq p1 (point)) (fsharp-end-of-block) (setq p2 (point)) (fsharp-eval-region p1 p2)))) (defun fsharp-load-buffer-file () "Load the filename corresponding to the present buffer in F# with #load" (interactive) (require 'inf-fsharp-mode) (let* ((name buffer-file-name) (command (concat "#load \"" name "\""))) (when (and (buffer-modified-p) (or fsharp-autosave-on-file-load (y-or-n-p (concat "Do you want to save \"" name "\" before loading it? ")))) (save-buffer)) (fsharp-run-process-if-needed) (fsharp-simple-send inferior-fsharp-buffer-name command))) (defun fsharp-show-subshell () (interactive) (require 'inf-fsharp-mode) (inferior-fsharp-show-subshell)) (defconst fsharp-error-regexp-fs "^\\([^(\n]+\\)(\\([0-9]+\\),\\([0-9]+\\)):" "Regular expression matching the error messages produced by fsc.") (if (boundp 'compilation-error-regexp-alist) (or (memq 'fsharp compilation-error-regexp-alist) (progn (add-to-list 'compilation-error-regexp-alist 'fsharp) (add-to-list 'compilation-error-regexp-alist-alist `(fsharp ,fsharp-error-regexp-fs 1 2 3))))) ;; Usual match-string doesn't work properly with font-lock-mode ;; on some emacs. (defun fsharp-match-string (num &optional string) "Return string of text matched by last search, without properties. NUM specifies which parenthesized expression in the last regexp. Value is nil if NUMth pair didn't match, or there were less than NUM pairs. Zero means the entire text matched by the whole regexp or whole string." (let* ((data (match-data)) (begin (nth (* 2 num) data)) (end (nth (1+ (* 2 num)) data))) (if string (substring string begin end) (buffer-substring-no-properties begin end)))) ;;; Project (defun fsharp-mode/find-sln-or-fsproj (dir-or-file) "Search for a solution or F# project file in any enclosing folders relative to DIR-OR-FILE." (fsharp-mode-search-upwards (rx (0+ nonl) (or ".fsproj" ".sln") eol) (file-name-directory dir-or-file))) (defun fsharp-mode-search-upwards (regex dir) (when dir (or (car-safe (directory-files dir 'full regex)) (fsharp-mode-search-upwards regex (fsharp-mode-parent-dir dir))))) (defun fsharp-mode-parent-dir (dir) (let ((p (file-name-directory (directory-file-name dir)))) (unless (equal p dir) p))) ;; Make project.el aware of fsharp projects (defun fsharp-mode-project-root (dir) (when-let (project-file (fsharp-mode/find-sln-or-fsproj dir)) (cons 'fsharp (file-name-directory project-file)))) (cl-defmethod project-roots ((project (head fsharp))) (list (cdr project))) (add-hook 'project-find-functions #'fsharp-mode-project-root) (provide 'fsharp-mode) ;;; fsharp-mode.el ends here ================================================ FILE: inf-fsharp-mode.el ================================================ ;;; inf-fsharp-mode.el --- Support for F# interactive ;; Copyright (C) 1997 INRIA ;; Author: 1993-1997 Xavier Leroy, Jacques Garrigue ;; 2010-2011 Laurent Le Brun ;; Maintainer: Robin Neatherway ;; Keywords: languages ;; This file is not part of GNU Emacs. ;; This file is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; This file is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. (require 'tramp) (require 'comint) (require 'fsharp-mode-util) (require 'cl-lib) ;; User modifiable variables ;; Whether you want the output buffer to be diplayed when you send a phrase (defvar fsharp-display-when-eval t "*If true, display the inferior fsharp buffer when evaluating expressions.") (defvar inferior-fsharp-program (cond ((executable-find "dotnet") "dotnet fsi --readline-") (fsharp-ac-using-mono "fsharpi --readline-") (t (concat "\"" (fsharp-mode--executable-find "fsi.exe") "\" --fsi-server-input-codepage:65001"))) "Inferior F# command.") ;; End of User modifiable variables (defvar inferior-fsharp-mode-map (let ((map (copy-keymap comint-mode-map))) (define-key map [M-return] 'fsharp-comint-send) map)) ;; Augment fsharp mode, so you can process fsharp code in the source files. (define-derived-mode inferior-fsharp-mode comint-mode "Inferior fsharp" "Major mode for interacting with an inferior fsharp process. Runs a fsharp toplevel as a subprocess of Emacs, with I/O through an Emacs buffer. A history of input phrases is maintained. Phrases can be sent from another buffer in fsharp mode. \\{inferior-fsharp-mode-map}" (setq comint-prompt-regexp "^> ?") (setq comint-prompt-read-only t) (set (make-local-variable 'paragraph-start) (concat "^$\\|" page-delimiter)) (set (make-local-variable 'paragraph-separate) paragraph-start) (set (make-local-variable 'paragraph-ignore-fill-prefix) t) (set (make-local-variable 'require-final-newline) t) (set (make-local-variable 'comment-start) "(*") (set (make-local-variable 'comment-end) "*)") (set (make-local-variable 'comment-column) 40) (set (make-local-variable 'comment-start-skip) "(\\*+ *") (set (make-local-variable 'parse-sexp-ignore-comments) nil) (set (make-local-variable 'comint-process-echoes) t) (run-hooks 'inferior-fsharp-mode-hooks) ;; use compilation mode to parse errors, but RET and C-cC-c should still be from comint-mode (compilation-minor-mode) (make-local-variable 'minor-mode-map-alist) (setq minor-mode-map-alist (assq-delete-all 'compilation-minor-mode (cl-copy-seq minor-mode-map-alist)))) (defconst inferior-fsharp-buffer-subname "inferior-fsharp") (defconst inferior-fsharp-buffer-name (concat "*" inferior-fsharp-buffer-subname "*")) (defun fsharp--localname (file) "Return localname of a Tramp filename. If FILE is not a Tramp filename return FILENAME" (if (tramp-tramp-file-p file) (with-parsed-tramp-file-name file nil localname) file)) (defun fsharp-run-process-if-needed (&optional cmd) "Launch fsi if needed, using CMD if supplied." (unless (comint-check-proc inferior-fsharp-buffer-name) (setq inferior-fsharp-program (or cmd (read-from-minibuffer "fsharp toplevel to run: " inferior-fsharp-program))) (let ((cmdlist (inferior-fsharp-args-to-list inferior-fsharp-program)) (process-connection-type 'pty)) (with-current-buffer (apply (function make-comint) inferior-fsharp-buffer-subname (car cmdlist) nil (cdr cmdlist)) (when (eq system-type 'windows-nt) (set-process-coding-system (get-buffer-process (current-buffer)) 'utf-8 'utf-8)) (inferior-fsharp-mode)) (display-buffer inferior-fsharp-buffer-name)))) ;;;###autoload (defun run-fsharp (&optional cmd) "Run an inferior fsharp process. Input and output via buffer `*inferior-fsharp*'." (interactive (list (if (not (comint-check-proc inferior-fsharp-buffer-name)) (read-from-minibuffer "fsharp toplevel to run: " inferior-fsharp-program)))) (fsharp-run-process-if-needed cmd) (switch-to-buffer-other-window inferior-fsharp-buffer-name)) ;; split the command line (e.g. "mono fsi" -> ("mono" "fsi")) ;; we double the \ before unquoting, so that the user doesn't have to (defun inferior-fsharp-args-to-list (string) (split-string-and-unquote (replace-regexp-in-string "\\\\" "\\\\\\\\" string))) (defun inferior-fsharp-show-subshell () (interactive) (fsharp-run-process-if-needed) (display-buffer inferior-fsharp-buffer-name) (let ((buf (current-buffer)) (fsharp-buf (get-buffer inferior-fsharp-buffer-name)) (count 0)) (while (and (< count 10) (not (equal (buffer-name (current-buffer)) inferior-fsharp-buffer-name))) (next-multiframe-window) (setq count (+ count 1))) (if (equal (buffer-name (current-buffer)) inferior-fsharp-buffer-name) (goto-char (point-max))) (while (> count 0) (previous-multiframe-window) (setq count (- count 1))))) (defun inferior-fsharp-eval-region (start end) "Send the current region to the inferior fsharp process." (interactive "r") (fsharp-run-process-if-needed) ;; send location to fsi (let* ((name (file-truename (buffer-file-name (current-buffer)))) (dir (fsharp--localname (file-name-directory name))) (line (number-to-string (line-number-at-pos start))) (loc (concat "# " line " \"" name "\"\n")) (movedir (concat "#silentCd @\"" dir "\";;\n"))) (comint-send-string inferior-fsharp-buffer-name movedir) (comint-send-string inferior-fsharp-buffer-name loc)) (save-excursion (goto-char end) (comint-send-region inferior-fsharp-buffer-name start (point)) ;; normally, ";;" are part of the region (if (and (>= (point) 2) (prog2 (backward-char 2) (looking-at ";;"))) (comint-send-string inferior-fsharp-buffer-name "\n") (comint-send-string inferior-fsharp-buffer-name "\n;;\n")) ;; the user may not want to see the output buffer (if fsharp-display-when-eval (display-buffer inferior-fsharp-buffer-name t)))) (defvar fsharp-previous-output nil "tells the beginning of output in the shell-output buffer, so that the output can be retreived later, asynchronously.") ;; To insert the last output from fsharp at point (defun fsharp-insert-last-output () "Insert the result of the evaluation of previous phrase" (interactive) (let ((pos (process-mark (get-buffer-process inferior-fsharp-buffer-name)))) (insert-buffer-substring inferior-fsharp-buffer-name fsharp-previous-output (- pos 2)))) (defun fsharp-simple-send (proc string) (comint-simple-send proc (concat string ";;"))) (defun fsharp-comint-send () (interactive) (let ((comint-input-sender 'fsharp-simple-send)) (comint-send-input))) (provide 'inf-fsharp-mode) ;;; inf-sharp-mode.el ends here ================================================ FILE: test/CompileCommandData/Directory With Spaces/noproj/test.fs ================================================ ================================================ FILE: test/CompileCommandData/Directory With Spaces/proj/test.fs ================================================ ================================================ FILE: test/CompileCommandData/Directory With Spaces/proj/test.fsproj ================================================ ================================================ FILE: test/CompileCommandData/noproj/test.fs ================================================ ================================================ FILE: test/CompileCommandData/proj/Makefile ================================================ ================================================ FILE: test/CompileCommandData/proj/test.fs ================================================ ================================================ FILE: test/CompileCommandData/proj/test.fsproj ================================================ ================================================ FILE: test/FindSlnData/bar.sln ================================================ ================================================ FILE: test/FindSlnData/noproj/test.fs ================================================ ================================================ FILE: test/FindSlnData/sln/foo.sln ================================================ ================================================ FILE: test/FindSlnData/test.fsproj ================================================ ================================================ FILE: test/StructureTest/Blocks.fs ================================================ let notABlock = 5 let basicBlock = [ 1; 2; 3 ] |> List.fold (fun x y -> x + y) type Shape = | Square | Rectangle | Triangle let aFunction x y = if x < y then x else y ================================================ FILE: test/StructureTest/BracketIndent.fs ================================================ let formatOne = [ "this" "that" "the-other" ] let formatTwo = [ "this" "that" ] let formatThree = [ "this" "that" "the-other" "hi" ] ================================================ FILE: test/StructureTest/ContinuationLines.fs ================================================ let x = 5 let y = [ 1; 2 ] |> List.fold (fun x y -> x + y) let z = 5 + 6 ================================================ FILE: test/StructureTest/Literals.fs ================================================ // Generated using https://hipsum.co/ // I'm a longer comment! Now, with Hipster Lorem Ipsum: // // Lorem ipsum dolor amet man braid +1 palo santo, whatever retro taxidermy // quinoa cred venmo church-key. Pok pok cray cornhole selvage irony keytar // disrupt man braid, everyday carry intelligentsia pitchfork street art hell // of. Schlitz air plant beard, fam authentic health goth hella fashion axe palo // santo pok pok. Hell of post-ironic artisan put a bird on it shoreditch shabby // chic. Bitters 3 wolf moon food truck adaptogen. // // Paleo fanny pack poutine, williamsburg health goth four dollar toast // aesthetic. Tbh viral truffaut live-edge asymmetrical ramps chillwave ethical // keytar fixie post-ironic vaporware air plant intelligentsia. Wayfarers // flannel iceland, DIY meditation celiac green juice disrupt. Food truck paleo // bicycle rights cold-pressed roof party normcore tumblr. let thisIsHereToBreakUpTheComments = 5 (* This is the same thing, but in a different comment syntax. *) (* Lorem ipsum dolor amet man braid +1 palo santo, whatever retro taxidermy quinoa cred venmo church-key. Pok pok cray cornhole selvage irony keytar disrupt man braid, everyday carry intelligentsia pitchfork street art hell of. Schlitz air plant beard, fam authentic health goth hella fashion axe palo santo pok pok. Hell of post-ironic artisan put a bird on it shoreditch shabby chic. Bitters 3 wolf moon food truck adaptogen. Paleo fanny pack poutine, williamsburg health goth four dollar toast aesthetic. Tbh viral truffaut live-edge asymmetrical ramps chillwave ethical keytar fixie post-ironic vaporware air plant intelligentsia. Wayfarers flannel iceland, DIY meditation celiac green juice disrupt. Food truck paleo bicycle rights cold-pressed roof party normcore tumblr. *) /// Yet again the same thing, but in a doc comment. /// /// Lorem ipsum dolor amet man braid +1 palo santo, whatever retro taxidermy /// quinoa cred venmo church-key. Pok pok cray cornhole selvage irony keytar /// disrupt man braid, everyday carry intelligentsia pitchfork street art hell /// of. Schlitz air plant beard, fam authentic health goth hella fashion axe /// palo santo pok pok. Hell of post-ironic artisan put a bird on it shoreditch /// shabby chic. Bitters 3 wolf moon food truck adaptogen. /// /// Paleo fanny pack poutine, williamsburg health goth four dollar toast /// aesthetic. Tbh viral truffaut live-edge asymmetrical ramps chillwave ethical /// keytar fixie post-ironic vaporware air plant intelligentsia. Wayfarers /// flannel iceland, DIY meditation celiac green juice disrupt. Food truck paleo /// bicycle rights cold-pressed roof party normcore tumblr. let simple = "this is a very normal string" let stringInString = "This contains another \"string\", so to speak." let longer = """ This is a triple-quoted string """ let evenLonger = """ This string is very long and had "normal extra quotes" and also a small number of \"escaped quotes\", and also a gratuitous it's. """ ================================================ FILE: test/StructureTest/Nesting.fs ================================================ // This file contains hand-crafted structures for use by `fsharp-mode-structure-tests.el`. // In particular, many/most of those tests need to work by: // // 1. Inserting text in a temp buffer // 2. Moving point to a known position // 3. Comparing computed values against expected answers // // Frequently, we're comparing things like, "what is the exact (point) position // of a given square brace." This means that formatting changes to this buffer // -- indeed, edits _of any kind_ -- will almost certainly break the tests! Edit // thoughtfully and intentionally! Update things as needed! // (point) of opening [: 640 let aList = [ 1; 2; 3] // (point) of inner opening [: 706 let nestedList = [ [ "this"; "that" ] ] // (point) of opening [: 777 let multiLineList = [ "this" "that" ] // (point) of outermost opening [: 947 // (point) of middle opening [: 953 // (point) of innermost opening [: 955 let multiLineNestedList = [ [ [ "how"; "now"] ] ] // (point) of opening {: 1060 // (point) of inner {: 1121 let anAsync = async { let value = funCall() let! differentValue = async { return! 5 } } // (point) of opening (: 1208 let thing = [ 1; 2] |> List.map (fun i -> i ** i ) ================================================ FILE: test/StructureTest/Relative.fs ================================================ type Test = | Unit | Integration of string | EndToEnd if thing <> true then printfn "thing is not true" else if thing = true then printfn "maybe?" else printfn "it is so" let aThing (test : Test) = function | Unit -> () | Integration -> () | EndToEnd -> () ================================================ FILE: test/Test1/Error.fs ================================================ module Error let x = nonexisting() ================================================ FILE: test/Test1/FileTwo.fs ================================================ module FileTwo type Foo = | Bar | Qux let addition x y = x + y let add x y = x + y type NewObjectType() = member x.Terrific (y : int) : int = y ================================================ FILE: test/Test1/NoProject.fs ================================================ module FileTwo open System.Collection ================================================ FILE: test/Test1/Pervasive.fs ================================================ let printtest args = printfn "Hello %d" 10 0 ================================================ FILE: test/Test1/Program.fs ================================================ module X = let func x = x + 1 let testval = FileTwo.NewObjectType() let val2 = X.func 2 let val3 = testval.Terrific val2 let val4 : FileTwo.NewObjectType = testval type Dummy = Foo | Bar let val5:Dummy = Foo [] let main args = printfn "Hello %d" val2 0 ================================================ FILE: test/Test1/Script.fsx ================================================ module XA = let funky x = x + 1 let val99 = XA.funky 21 ================================================ FILE: test/Test1/Test1.fsproj ================================================  Exe net9.0 ================================================ FILE: test/Test2/Main.fs ================================================ module Test2.Main let val2 = List.map ((+) 1) [1;2] [] let main args = printfn "Hello %A" val2 0 ================================================ FILE: test/Test2/Test2.fsproj ================================================ Debug x86 8.0.30703 2.0 {116cc2f9-f987-4b3d-915a-34cac04a73db} Library Test2 Test2 Test2 False Program.fs 4.3.0.0 11 True full False False bin\Debug\ DEBUG;TRACE 3 x86 bin\Debug\Test2.XML pdbonly True True bin\Release\ TRACE 3 x86 bin\Release\Test2.XML False True {116cc2f9-f987-4b3d-915a-34cac04a73da} Test1 $(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets $(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets ================================================ FILE: test/apps/FQuake3/NativeMappings.fs ================================================ (* Copyright (C) 2013 William F. Smith This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Derivative of Quake III Arena source: Copyright (C) 1999-2005 Id Software, Inc. *) // Disable native interop warnings #nowarn "9" #nowarn "51" namespace Engine.Native open System open System.IO open System.Runtime.InteropServices open Microsoft.FSharp.NativeInterop open FSharp.Game.Math open Engine.Core open Engine.Net open Engine.FileSystem open Engine.NativeInterop open FQuake3.Math open FQuake3.Md3 /// Used to prevent massive copying of large immutable data. module private Cache = let mutable md3Map = Map.empty module Boolean = let inline ofNativePtr (ptr: nativeptr) = let mutable native = NativePtr.read ptr match native with | qboolean.qtrue -> true | _ -> false let inline toNativeByPtr (ptr: nativeptr) (value: bool) = let mutable native = NativePtr.read ptr native <- if value then qboolean.qtrue else qboolean.qfalse NativePtr.write ptr native let inline toNative (value: bool) = if value then qboolean.qtrue else qboolean.qfalse module Vec2 = let inline ofNativePtr (ptr: nativeptr) = let mutable native = NativePtr.read ptr vec2 (native.value, native.value1) let inline toNativeByPtr (ptr: nativeptr) (v: vec2) = let mutable native = NativePtr.read ptr native.value <- v.X native.value1 <- v.Y NativePtr.write ptr native module Vec3 = let inline ofNativePtr (ptr: nativeptr) = let mutable native = NativePtr.read ptr vec3 (native.value, native.value1, native.value2) let inline toNativeByPtr (ptr: nativeptr) (v: vec3) = let mutable native = NativePtr.read ptr native.value <- v.X native.value1 <- v.Y native.value2 <- v.Z NativePtr.write ptr native module Vec4 = let inline ofNativePtr (ptr: nativeptr) = let mutable native = NativePtr.read ptr vec4 (native.value, native.value1, native.value2, native.value3) let inline toNativeByPtr (ptr: nativeptr) (v: vec4) = let mutable native = NativePtr.read ptr native.value <- v.X native.value1 <- v.Y native.value2 <- v.Z native.value3 <- v.W NativePtr.write ptr native module Mat4 = let inline ofNativePtr (ptr: nativeptr) = mat4 ( (NativePtr.get ptr 0), (NativePtr.get ptr 1), (NativePtr.get ptr 2), (NativePtr.get ptr 3), (NativePtr.get ptr 4), (NativePtr.get ptr 5), (NativePtr.get ptr 6), (NativePtr.get ptr 7), (NativePtr.get ptr 8), (NativePtr.get ptr 9), (NativePtr.get ptr 10), (NativePtr.get ptr 11), (NativePtr.get ptr 12), (NativePtr.get ptr 13), (NativePtr.get ptr 14), (NativePtr.get ptr 15) ) let inline toNativeByPtr (ptr: nativeptr) (m: mat4) = NativePtr.set ptr 0 m.[0, 0] NativePtr.set ptr 1 m.[0, 1] NativePtr.set ptr 2 m.[0, 2] NativePtr.set ptr 3 m.[0, 3] NativePtr.set ptr 4 m.[1, 0] NativePtr.set ptr 5 m.[1, 1] NativePtr.set ptr 6 m.[1, 2] NativePtr.set ptr 7 m.[1, 3] NativePtr.set ptr 8 m.[2, 0] NativePtr.set ptr 9 m.[2, 1] NativePtr.set ptr 10 m.[2, 2] NativePtr.set ptr 11 m.[2, 3] NativePtr.set ptr 12 m.[3, 0] NativePtr.set ptr 13 m.[3, 1] NativePtr.set ptr 14 m.[3, 2] NativePtr.set ptr 15 m.[3, 3] module Cvar = let inline ofNativePtr (ptr: nativeptr) = let mutable native = NativePtr.read ptr { Name = NativePtr.toStringAnsi native.name; String = NativePtr.toStringAnsi native.string; ResetString = NativePtr.toStringAnsi native.resetString; LatchedString = NativePtr.toStringAnsi native.latchedString; Flags = native.flags; IsModified = Boolean.ofNativePtr &&native.modified; ModificationCount = native.modificationCount; Value = native.value; Integer = native.integer; } module Bounds = let inline ofNativePtr (ptr: nativeptr) = Bounds ( Vec3.ofNativePtr <| NativePtr.add ptr 0, Vec3.ofNativePtr <| NativePtr.add ptr 1) let inline toNativeByPtr (ptr: nativeptr) (bounds: Bounds) = let mutable nativeX = NativePtr.get ptr 0 let mutable nativeY = NativePtr.get ptr 1 Vec3.toNativeByPtr &&nativeX bounds.Min Vec3.toNativeByPtr &&nativeY bounds.Max NativePtr.set ptr 0 nativeX NativePtr.set ptr 1 nativeY module Message = let inline ofNativePtr (ptr: nativeptr) = let mutable native = NativePtr.read ptr { IsAllowedOverflow = Boolean.ofNativePtr &&native.allowoverflow; IsOverflowed = Boolean.ofNativePtr &&native.overflowed; IsOutOfBand = Boolean.ofNativePtr &&native.oob; Data = Seq.ofNativePtrArray native.cursize native.data; MaxSize = native.maxsize; ReadCount = native.readcount; Bit = native.bit; } module IPAddress = let inline ofNativePtr (ptr: nativeptr) = { Octet1 = NativePtr.get ptr 0; Octet2 = NativePtr.get ptr 1; Octet3 = NativePtr.get ptr 2; Octet4 = NativePtr.get ptr 3; } module Address = let inline ofNativePtr (ptr: nativeptr) = let mutable native = NativePtr.read ptr { Type = enum (int native.type'); IP = IPAddress.ofNativePtr &&native.ip Port = native.port; } module Md3Frame = let inline ofNativePtr (ptr: nativeptr) = let mutable native = NativePtr.read ptr { Bounds = Bounds.ofNativePtr &&native.bounds; LocalOrigin = Vec3.ofNativePtr &&native.localOrigin; Radius = native.radius; Name = NativePtr.toStringAnsi &&native.name; } module Md3 = let ofNativePtr (ptr: nativeptr) = let mutable native = NativePtr.read ptr let hash = NativePtr.toNativeInt ptr match Map.tryFind hash Cache.md3Map with | Some x -> x | None -> let bytes = Array.zeroCreate native.ofsEnd Marshal.Copy (NativePtr.toNativeInt ptr, bytes, 0, native.ofsEnd) let md3 = FQuake3.Utils.Md3.parse bytes Cache.md3Map <- Map.add hash md3 Cache.md3Map md3 module DirectoryInfo = let ofNativePtr (ptr: nativeptr) = let mutable native = NativePtr.read ptr let path = NativePtr.toStringAnsi &&native.path let name = NativePtr.toStringAnsi &&native.gamedir DirectoryInfo (Path.Combine (path, name)) module Pak = let ofNativePtr (ptr: nativeptr) = let mutable native = NativePtr.read ptr { FileInfo = FileInfo (NativePtr.toStringAnsi &&native.pakFilename); Checksum = native.checksum; PureChecksum = native.checksum; FileCount = native.numfiles; } module ServerPakChecksum = let createFrom_fs_serverPaks (size: int) (ptr: nativeptr) = match NativePtr.isValid ptr with | false -> [] | _ -> NativePtr.toList size ptr module SearchPath = let ofNativePtr (ptr: nativeptr) = let mutable native = NativePtr.read ptr { DirectoryInfo = Option.ofNativePtr DirectoryInfo.ofNativePtr native.directory } let convertFrom_fs_searchpaths (ptr: nativeptr) = let rec f (searchPaths: SearchPath list) (ptr: nativeptr) = match NativePtr.isValid ptr with | false -> searchPaths | _ -> let mutable native = NativePtr.read ptr f (ofNativePtr ptr :: searchPaths) (native.next) f [] ptr ================================================ FILE: test/apps/FQuake3/NativeMappings.fs.faceup ================================================ «x:(* Copyright (C) 2013 William F. Smith This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Derivative of Quake III Arena source: Copyright (C) 1999-2005 Id Software, Inc. *)» «m:// »«x:Disable native interop warnings »«k:#nowarn» «s:"9"» «k:#nowarn» «s:"51"» «k:namespace» «v:Engine».«v:Native» «k:open» «v:System» «k:open» «v:System».«v:IO» «k:open» «v:System».«v:Runtime».«v:InteropServices» «k:open» «v:Microsoft».«v:FSharp».«v:NativeInterop» «k:open» «v:FSharp».«v:Game».«v:Math» «k:open» «v:Engine».«v:Core» «k:open» «v:Engine».«v:Net» «k:open» «v:Engine».«v:FileSystem» «k:open» «v:Engine».«v:NativeInterop» «k:open» «v:FQuake3».«v:Math» «k:open» «v:FQuake3».«v:Md3» «m:/// »«x:Used to prevent massive copying of large immutable data. »«k:module» «k:private» «v:Cache» = «k:let» «k:mutable» «v:md3Map» = Map.empty «k:module» «t:Boolean» = «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = «k:let» «k:mutable» «v:native» = NativePtr.read ptr «k:match» native «k:with» «:fsharp-ui-operator-face:|» qboolean.qtrue -> «k:true» «:fsharp-ui-operator-face:|» _ -> «k:false» «k:let» «k:inline» «f:toNativeByPtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») («v:value»: «t:bool») = «k:let» «k:mutable» «v:native» = NativePtr.read ptr native <- «k:if» value «k:then» qboolean.qtrue «k:else» qboolean.qfalse NativePtr.write ptr native «k:let» «k:inline» «f:toNative» («v:value»: «t:bool») = «k:if» value «k:then» qboolean.qtrue «k:else» qboolean.qfalse «k:module» «t:Vec2» = «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = «k:let» «k:mutable» «v:native» = NativePtr.read ptr vec2 (native.value, native.value1) «k:let» «k:inline» «f:toNativeByPtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») («v:v»: «t:vec2») = «k:let» «k:mutable» «v:native» = NativePtr.read ptr native.value <- v.X native.value1 <- v.Y NativePtr.write ptr native «k:module» «t:Vec3» = «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = «k:let» «k:mutable» «v:native» = NativePtr.read ptr vec3 (native.value, native.value1, native.value2) «k:let» «k:inline» «f:toNativeByPtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») («v:v»: «t:vec3») = «k:let» «k:mutable» «v:native» = NativePtr.read ptr native.value <- v.X native.value1 <- v.Y native.value2 <- v.Z NativePtr.write ptr native «k:module» «t:Vec4» = «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = «k:let» «k:mutable» «v:native» = NativePtr.read ptr vec4 (native.value, native.value1, native.value2, native.value3) «k:let» «k:inline» «f:toNativeByPtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») («v:v»: «t:vec4») = «k:let» «k:mutable» «v:native» = NativePtr.read ptr native.value <- v.X native.value1 <- v.Y native.value2 <- v.Z native.value3 <- v.W NativePtr.write ptr native «k:module» «t:Mat4» = «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = mat4 ( (NativePtr.get ptr 0), (NativePtr.get ptr 1), (NativePtr.get ptr 2), (NativePtr.get ptr 3), (NativePtr.get ptr 4), (NativePtr.get ptr 5), (NativePtr.get ptr 6), (NativePtr.get ptr 7), (NativePtr.get ptr 8), (NativePtr.get ptr 9), (NativePtr.get ptr 10), (NativePtr.get ptr 11), (NativePtr.get ptr 12), (NativePtr.get ptr 13), (NativePtr.get ptr 14), (NativePtr.get ptr 15) ) «k:let» «k:inline» «f:toNativeByPtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») («v:m»: «t:mat4») = NativePtr.set ptr 0 m.[0, 0] NativePtr.set ptr 1 m.[0, 1] NativePtr.set ptr 2 m.[0, 2] NativePtr.set ptr 3 m.[0, 3] NativePtr.set ptr 4 m.[1, 0] NativePtr.set ptr 5 m.[1, 1] NativePtr.set ptr 6 m.[1, 2] NativePtr.set ptr 7 m.[1, 3] NativePtr.set ptr 8 m.[2, 0] NativePtr.set ptr 9 m.[2, 1] NativePtr.set ptr 10 m.[2, 2] NativePtr.set ptr 11 m.[2, 3] NativePtr.set ptr 12 m.[3, 0] NativePtr.set ptr 13 m.[3, 1] NativePtr.set ptr 14 m.[3, 2] NativePtr.set ptr 15 m.[3, 3] «k:module» «t:Cvar» = «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = «k:let» «k:mutable» «v:native» = NativePtr.read ptr { Name = NativePtr.toStringAnsi native.name; String = NativePtr.toStringAnsi native.string; ResetString = NativePtr.toStringAnsi native.resetString; LatchedString = NativePtr.toStringAnsi native.latchedString; Flags = native.flags; IsModified = Boolean.ofNativePtr &&native.modified; ModificationCount = native.modificationCount; Value = native.value; Integer = native.integer; } «k:module» «t:Bounds» = «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = Bounds ( Vec3.ofNativePtr «:fsharp-ui-operator-face:<|» NativePtr.add ptr 0, Vec3.ofNativePtr «:fsharp-ui-operator-face:<|» NativePtr.add ptr 1) «k:let» «k:inline» «f:toNativeByPtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») («v:bounds»: «t:Bounds») = «k:let» «k:mutable» «v:nativeX» = NativePtr.get ptr 0 «k:let» «k:mutable» «v:nativeY» = NativePtr.get ptr 1 Vec3.toNativeByPtr &&nativeX bounds.Min Vec3.toNativeByPtr &&nativeY bounds.Max NativePtr.set ptr 0 nativeX NativePtr.set ptr 1 nativeY «k:module» «t:Message» = «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = «k:let» «k:mutable» «v:native» = NativePtr.read ptr { IsAllowedOverflow = Boolean.ofNativePtr &&native.allowoverflow; IsOverflowed = Boolean.ofNativePtr &&native.overflowed; IsOutOfBand = Boolean.ofNativePtr &&native.oob; Data = Seq.ofNativePtrArray native.cursize native.data; MaxSize = native.maxsize; ReadCount = native.readcount; Bit = native.bit; } «k:module» «t:IPAddress» = «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = { Octet1 = NativePtr.get ptr 0; Octet2 = NativePtr.get ptr 1; Octet3 = NativePtr.get ptr 2; Octet4 = NativePtr.get ptr 3; } «k:module» «t:Address» = «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = «k:let» «k:mutable» «v:native» = NativePtr.read ptr { Type = enum (int native.type'); IP = IPAddress.ofNativePtr &&native.ip Port = native.port; } «k:module» «t:Md3Frame» = «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = «k:let» «k:mutable» «v:native» = NativePtr.read ptr { Bounds = Bounds.ofNativePtr &&native.bounds; LocalOrigin = Vec3.ofNativePtr &&native.localOrigin; Radius = native.radius; Name = NativePtr.toStringAnsi &&native.name; } «k:module» «t:Md3» = «k:let» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = «k:let» «k:mutable» «v:native» = NativePtr.read ptr «k:let» «v:hash» = NativePtr.toNativeInt ptr «k:match» Map.tryFind hash Cache.md3Map «k:with» «:fsharp-ui-operator-face:|» Some x -> x «:fsharp-ui-operator-face:|» None -> «k:let» «v:bytes» = Array.zeroCreate native.ofsEnd Marshal.Copy (NativePtr.toNativeInt ptr, bytes, 0, native.ofsEnd) «k:let» «v:md3» = FQuake3.Utils.Md3.parse bytes Cache.md3Map <- Map.add hash md3 Cache.md3Map md3 «k:module» «t:DirectoryInfo» = «k:let» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = «k:let» «k:mutable» «v:native» = NativePtr.read ptr «k:let» «v:path» = NativePtr.toStringAnsi &&native.path «k:let» «v:name» = NativePtr.toStringAnsi &&native.gamedir DirectoryInfo (Path.Combine (path, name)) «k:module» «t:Pak» = «k:let» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = «k:let» «k:mutable» «v:native» = NativePtr.read ptr { FileInfo = FileInfo (NativePtr.toStringAnsi &&native.pakFilename); Checksum = native.checksum; PureChecksum = native.checksum; FileCount = native.numfiles; } «k:module» «t:ServerPakChecksum» = «k:let» «f:createFrom_fs_serverPaks» («v:size»: «t:int») («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = «k:match» NativePtr.isValid ptr «k:with» «:fsharp-ui-operator-face:|» «k:false» -> [] «:fsharp-ui-operator-face:|» _ -> NativePtr.toList size ptr «k:module» «t:SearchPath» = «k:let» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = «k:let» «k:mutable» «v:native» = NativePtr.read ptr { DirectoryInfo = Option.ofNativePtr DirectoryInfo.ofNativePtr native.directory } «k:let» «f:convertFrom_fs_searchpaths» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = «k:let» «k:rec» «f:f» («v:searchPaths»: «t:SearchPath list») («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = «k:match» NativePtr.isValid ptr «k:with» «:fsharp-ui-operator-face:|» «k:false» -> searchPaths «:fsharp-ui-operator-face:|» _ -> «k:let» «k:mutable» «v:native» = NativePtr.read ptr f (ofNativePtr ptr :: searchPaths) (native.next) f [] ptr ================================================ FILE: test/apps/FSharp.Compatibility/Format.fs ================================================ (* OCaml Compatibility Library for F# (Format module) (FSharp.Compatibility.OCaml.Format) Copyright (c) 1996 Institut National de Recherche en Informatique et en Automatique Copyright (c) Jack Pappas 2012 http://github.com/jack-pappas This code is distributed under the terms of the GNU Lesser General Public License (LGPL) v2.1. See the LICENSE file for details. *) // References: // http://caml.inria.fr/pub/docs/manual-ocaml/libref/Format.html /// Pretty printing. [] module FSharp.Compatibility.OCaml.Format (************************************************************** Data structures definitions. **************************************************************) // TODO : Recreate 'size' as a measure type on int type size = int let inline size_of_int (n : int) : size = n let inline int_of_size (s : size) : int = s (* Tokens are one of the following : *) type pp_token = (* normal text *) | Pp_text of string (* complete break *) | Pp_break of int * int (* go to next tabulation *) | Pp_tbreak of int * int (* set a tabulation *) | Pp_stab (* beginning of a block *) | Pp_begin of int * block_type (* end of a block *) | Pp_end (* beginning of a tabulation block *) | Pp_tbegin of tblock (* end of a tabulation block *) | Pp_tend (* to force a newline inside a block *) | Pp_newline (* to do something only if this very line has been broken *) | Pp_if_newline (* opening a tag name *) | Pp_open_tag of tag (* closing the most recently opened tag *) | Pp_close_tag and tag = string and block_type = (* Horizontal block no line breaking *) | Pp_hbox (* Vertical block each break leads to a new line *) | Pp_vbox (* Horizontal-vertical block: same as vbox, except if this block is small enough to fit on a single line *) | Pp_hvbox (* Horizontal or Vertical block: breaks lead to new line only when necessary to print the content of the block *) | Pp_hovbox (* Horizontal or Indent block: breaks lead to new line only when necessary to print the content of the block, or when it leads to a new indentation of the current line *) | Pp_box (* Internal usage: when a block fits on a single line *) | Pp_fits and tblock = (* Tabulation box *) | Pp_tbox of (int list) ref (* The Queue: contains all formatting elements. elements are tuples (size, token, length), where size is set when the size of the block is known len is the declared length of the token. *) type pp_queue_elem = { mutable elem_size : size; token : pp_token; length : int; } (* Scan stack: each element is (left_total, queue element) where left_total is the value of pp_left_total when the element has been enqueued. *) type pp_scan_elem = | Scan_elem of int * pp_queue_elem (* Formatting stack: used to break the lines while printing tokens. The formatting stack contains the description of the currently active blocks. *) type pp_format_elem = | Format_elem of block_type * int (* General purpose queues, used in the formatter. *) type 'a queue_elem = | Nil | Cons of 'a queue_cell and 'a queue_cell = { mutable head : 'a; mutable tail : 'a queue_elem; } type 'a queue = { mutable insert : 'a queue_elem; mutable body : 'a queue_elem; } (* The formatter specific tag handling functions. *) type formatter_tag_functions = { mark_open_tag : tag -> string; mark_close_tag : tag -> string; print_open_tag : tag -> unit; print_close_tag : tag -> unit; } (* A formatter with all its machinery. *) type formatter = { mutable pp_scan_stack : pp_scan_elem list; mutable pp_format_stack : pp_format_elem list; mutable pp_tbox_stack : tblock list; mutable pp_tag_stack : tag list; mutable pp_mark_stack : tag list; (* Global variables: default initialization is set_margin 78 set_min_space_left 0. *) /// Value of right margin. mutable pp_margin : int; /// Minimal space left before margin, when opening a block. mutable pp_min_space_left : int; /// Maximum value of indentation: no blocks can be opened further. mutable pp_max_indent : int; /// Space remaining on the current line. mutable pp_space_left : int; /// Current value of indentation. mutable pp_current_indent : int; /// True when the line has been broken by the pretty-printer. mutable pp_is_new_line : bool; /// Total width of tokens already printed. mutable pp_left_total : int; /// Total width of tokens ever put in queue. mutable pp_right_total : int; /// Current number of opened blocks. mutable pp_curr_depth : int; /// Maximum number of blocks which can be simultaneously opened. mutable pp_max_boxes : int; /// Ellipsis string. mutable pp_ellipsis : string; /// Output function. mutable pp_out_string : string -> int -> int -> unit; /// Flushing function. mutable pp_out_flush : unit -> unit; /// Output of new lines. mutable pp_out_newline : unit -> unit; /// Output of indentation spaces. mutable pp_out_spaces : int -> unit; /// Are tags printed? mutable pp_print_tags : bool; /// Are tags marked? mutable pp_mark_tags : bool; /// Find opening and closing markers of tags. mutable pp_mark_open_tag : tag -> string; mutable pp_mark_close_tag : tag -> string; mutable pp_print_open_tag : tag -> unit; mutable pp_print_close_tag : tag -> unit; /// The pretty-printer queue. mutable pp_queue : pp_queue_elem queue } (************************************************************** Auxilliaries and basic functions. **************************************************************) /// Queues auxilliaries. let make_queue () = { insert = Nil; body = Nil; } let clear_queue q = q.insert <- Nil q.body <- Nil let add_queue x q = let c = Cons { head = x; tail = Nil; } match q with | { insert = Cons cell; body = _ } -> (q.insert <- c; cell.tail <- c) | (* Invariant: when insert is Nil body should be Nil. *) { insert = Nil; body = _ } -> (q.insert <- c; q.body <- c) exception Empty_queue let peek_queue = function | { body = Cons { head = x; tail = _ }; insert = _ } -> x | { body = Nil; insert = _ } -> raise Empty_queue let take_queue = function | ({ body = Cons { head = x; tail = tl }; insert = _ } as q) -> (q.body <- tl; if tl = Nil then q.insert <- Nil else (); (* Maintain the invariant. *) x) | { body = Nil; insert = _ } -> raise Empty_queue (* Enter a token in the pretty-printer queue. *) let pp_enqueue state (({ length = len; elem_size = _; token = _ } as token)) = state.pp_right_total <- state.pp_right_total + len add_queue token state.pp_queue let pp_clear_queue state = state.pp_left_total <- 1 state.pp_right_total <- 1 clear_queue state.pp_queue (* Pp_infinity: large value for default tokens size. Pp_infinity is documented as being greater than 1e10; to avoid confusion about the word ``greater'', we choose pp_infinity greater than 1e10 + 1; for correct handling of tests in the algorithm, pp_infinity must be even one more than 1e10 + 1; let's stand on the safe side by choosing 1.e10+10. Pp_infinity could probably be 1073741823 that is 2^30 - 1, that is the minimal upper bound for integers; now that max_int is defined, this limit could also be defined as max_int - 1. However, before setting pp_infinity to something around max_int, we must carefully double-check all the integer arithmetic operations that involve pp_infinity, since any overflow would wreck havoc the pretty-printing algorithm's invariants. Given that this arithmetic correctness check is difficult and error prone and given that 1e10 + 1 is in practice large enough, there is no need to attempt to set pp_infinity to the theoretically maximum limit. It is not worth the burden ! *) let pp_infinity = 1000000010 (* Output functions for the formatter. *) let rec pp_output_string state s = state.pp_out_string s 0 (String.length s) and pp_output_newline state = state.pp_out_newline () and pp_output_spaces state n = state.pp_out_spaces n (* To format a break, indenting a new line. *) let break_new_line state offset width = (pp_output_newline state; state.pp_is_new_line <- true; let indent = (state.pp_margin - width) + offset in (* Don't indent more than pp_max_indent. *) let real_indent = min state.pp_max_indent indent in (state.pp_current_indent <- real_indent; state.pp_space_left <- state.pp_margin - state.pp_current_indent; pp_output_spaces state state.pp_current_indent)) (* To force a line break inside a block: no offset is added. *) let break_line state width = break_new_line state 0 width (* To format a break that fits on the current line. *) let break_same_line state width = (state.pp_space_left <- state.pp_space_left - width; pp_output_spaces state width) (* To indent no more than pp_max_indent, if one tries to open a block beyond pp_max_indent, then the block is rejected on the left by simulating a break. *) let pp_force_break_line state = match state.pp_format_stack with | Format_elem (bl_ty, width) :: _ -> if width > state.pp_space_left then (match bl_ty with | Pp_fits -> () | Pp_hbox -> () | Pp_vbox | Pp_hvbox | Pp_hovbox | Pp_box -> break_line state width) else () | [] -> pp_output_newline state (* To skip a token, if the previous line has been broken. *) let pp_skip_token state = (* When calling pp_skip_token the queue cannot be empty. *) match take_queue state.pp_queue with | { elem_size = size; length = len; token = _ } -> (state.pp_left_total <- state.pp_left_total - len; state.pp_space_left <- state.pp_space_left + (int_of_size size)) (************************************************************** The main pretty printing functions. **************************************************************) (* To format a token. *) let format_pp_token state size = function | Pp_text s -> (state.pp_space_left <- state.pp_space_left - size; pp_output_string state s; state.pp_is_new_line <- false) | Pp_begin (off, ty) -> let insertion_point = state.pp_margin - state.pp_space_left in (if insertion_point > state.pp_max_indent then (* can't open a block right there. *) pp_force_break_line state else (); let offset = state.pp_space_left - off in let bl_type = (match ty with | Pp_vbox -> Pp_vbox | Pp_hbox | Pp_hvbox | Pp_hovbox | Pp_box | Pp_fits -> if size > state.pp_space_left then ty else Pp_fits) in state.pp_format_stack <- (Format_elem (bl_type, offset)) :: state.pp_format_stack) | Pp_end -> (match state.pp_format_stack with | _ :: ls -> state.pp_format_stack <- ls | [] -> ()) | (* No more block to close. *) Pp_tbegin ((Pp_tbox _ as tbox)) -> state.pp_tbox_stack <- tbox :: state.pp_tbox_stack | Pp_tend -> (match state.pp_tbox_stack with | _ :: ls -> state.pp_tbox_stack <- ls | [] -> ()) | (* No more tabulation block to close. *) Pp_stab -> (match state.pp_tbox_stack with | Pp_tbox tabs :: _ -> let rec add_tab n = (function | [] -> [ n ] | (x :: l as ls) -> if n < x then n :: ls else x :: (add_tab n l)) in tabs := add_tab (state.pp_margin - state.pp_space_left) !tabs | [] -> ()) | (* No opened tabulation block. *) Pp_tbreak (n, off) -> let insertion_point = state.pp_margin - state.pp_space_left in (match state.pp_tbox_stack with | Pp_tbox tabs :: _ -> let rec find n = (function | x :: l -> if x >= n then x else find n l | [] -> raise Not_found) in let tab = (match !tabs with | x :: _ -> (try find insertion_point !tabs with | Not_found -> x) | _ -> insertion_point) in let offset = tab - insertion_point in if offset >= 0 then break_same_line state (offset + n) else break_new_line state (tab + off) state.pp_margin | [] -> ()) | (* No opened tabulation block. *) Pp_newline -> (match state.pp_format_stack with | Format_elem (_, width) :: _ -> break_line state width | [] -> pp_output_newline state) | (* No opened block. *) Pp_if_newline -> if state.pp_current_indent <> (state.pp_margin - state.pp_space_left) then pp_skip_token state | Pp_break (n, off) -> (match state.pp_format_stack with | Format_elem (ty, width) :: _ -> (match ty with | Pp_hovbox -> if size > state.pp_space_left then break_new_line state off width else break_same_line state n | Pp_box -> (* Have the line just been broken here ? *) if state.pp_is_new_line then break_same_line state n else if size > state.pp_space_left then break_new_line state off width else (* break the line here leads to new indentation ? *) if state.pp_current_indent > ((state.pp_margin - width) + off) then break_new_line state off width else break_same_line state n | Pp_hvbox -> break_new_line state off width | Pp_fits -> break_same_line state n | Pp_vbox -> break_new_line state off width | Pp_hbox -> break_same_line state n) | [] -> ()) | (* No opened block. *) Pp_open_tag tag_name -> let marker = state.pp_mark_open_tag tag_name in (pp_output_string state marker; state.pp_mark_stack <- tag_name :: state.pp_mark_stack) | Pp_close_tag -> (match state.pp_mark_stack with | tag_name :: tags -> let marker = state.pp_mark_close_tag tag_name in (pp_output_string state marker; state.pp_mark_stack <- tags) | [] -> ()) (* No more tag to close. *) (* Print if token size is known or printing is delayed. Size is known when not negative. Printing is delayed when the text waiting in the queue requires more room to format than exists on the current line. Note: [advance_loop] must be tail recursive to prevent stack overflows. *) let rec advance_loop state = match peek_queue state.pp_queue with | { elem_size = size; token = tok; length = len } -> let size = int_of_size size in if not ((size < 0) && ((state.pp_right_total - state.pp_left_total) < state.pp_space_left)) then (ignore (take_queue state.pp_queue); format_pp_token state (if size < 0 then pp_infinity else size) tok; state.pp_left_total <- len + state.pp_left_total; advance_loop state) else () let advance_left state = try advance_loop state with | Empty_queue -> () let enqueue_advance state tok = (pp_enqueue state tok; advance_left state) (* To enqueue a string : try to advance. *) let make_queue_elem size tok len = { elem_size = size; token = tok; length = len; } let enqueue_string_as state size s = let len = int_of_size size in enqueue_advance state (make_queue_elem size (Pp_text s) len) let enqueue_string state s = let len = String.length s in enqueue_string_as state (size_of_int len) s (* Routines for scan stack determine sizes of blocks. *) (* The scan_stack is never empty. *) let scan_stack_bottom = let q_elem = make_queue_elem (size_of_int (-1)) (Pp_text "") 0 in [ Scan_elem ((-1), q_elem) ] (* Set size of blocks on scan stack: if ty = true then size of break is set else size of block is set; in each case pp_scan_stack is popped. *) let clear_scan_stack state = state.pp_scan_stack <- scan_stack_bottom (* Pattern matching on scan stack is exhaustive, since scan_stack is never empty. Pattern matching on token in scan stack is also exhaustive, since scan_push is used on breaks and opening of boxes. *) let set_size state ty = match state.pp_scan_stack with | Scan_elem (left_tot, (({ elem_size = size; token = tok; length = _ } as queue_elem))) :: t -> let size = int_of_size size in (* test if scan stack contains any data that is not obsolete. *) if left_tot < state.pp_left_total then clear_scan_stack state else (match tok with | Pp_break (_, _) | Pp_tbreak (_, _) -> if ty then (queue_elem.elem_size <- size_of_int (state.pp_right_total + size); state.pp_scan_stack <- t) else () | Pp_begin (_, _) -> if not ty then (queue_elem.elem_size <- size_of_int (state.pp_right_total + size); state.pp_scan_stack <- t) else () | Pp_text _ | Pp_stab | Pp_tbegin _ | Pp_tend | Pp_end | Pp_newline | Pp_if_newline | Pp_open_tag _ | Pp_close_tag -> ()) | (* scan_push is only used for breaks and boxes. *) [] -> () (* scan_stack is never empty. *) (* Push a token on scan stack. If b is true set_size is called. *) let scan_push state b tok = (pp_enqueue state tok; if b then set_size state true else (); state.pp_scan_stack <- (Scan_elem (state.pp_right_total, tok)) :: state.pp_scan_stack) (* To open a new block : the user may set the depth bound pp_max_boxes any text nested deeper is printed as the ellipsis string. *) let pp_open_box_gen state indent br_ty = (state.pp_curr_depth <- state.pp_curr_depth + 1; if state.pp_curr_depth < state.pp_max_boxes then (let elem = make_queue_elem (size_of_int (- state.pp_right_total)) (Pp_begin (indent, br_ty)) 0 in scan_push state false elem) else if state.pp_curr_depth = state.pp_max_boxes then enqueue_string state state.pp_ellipsis else ()) (* The box which is always opened. *) let pp_open_sys_box state = pp_open_box_gen state 0 Pp_hovbox (* Close a block, setting sizes of its sub blocks. *) let pp_close_box state () = if state.pp_curr_depth > 1 then (if state.pp_curr_depth < state.pp_max_boxes then (pp_enqueue state { elem_size = size_of_int 0; token = Pp_end; length = 0; }; set_size state true; set_size state false) else (); state.pp_curr_depth <- state.pp_curr_depth - 1) else () (* Open a tag, pushing it on the tag stack. *) let pp_open_tag state tag_name = (if state.pp_print_tags then (state.pp_tag_stack <- tag_name :: state.pp_tag_stack; state.pp_print_open_tag tag_name) else (); if state.pp_mark_tags then pp_enqueue state { elem_size = size_of_int 0; token = Pp_open_tag tag_name; length = 0; } else ()) (* Close a tag, popping it from the tag stack. *) let pp_close_tag state () = (if state.pp_mark_tags then pp_enqueue state { elem_size = size_of_int 0; token = Pp_close_tag; length = 0; } else (); if state.pp_print_tags then (match state.pp_tag_stack with | tag_name :: tags -> (state.pp_print_close_tag tag_name; state.pp_tag_stack <- tags) | _ -> ()) else ()) (* No more tag to close. *) let pp_set_print_tags state b = state.pp_print_tags <- b let pp_set_mark_tags state b = state.pp_mark_tags <- b let pp_get_print_tags state () = state.pp_print_tags let pp_get_mark_tags state () = state.pp_mark_tags let pp_set_tags state b = (pp_set_print_tags state b; pp_set_mark_tags state b) let pp_get_formatter_tag_functions state () = { mark_open_tag = state.pp_mark_open_tag; mark_close_tag = state.pp_mark_close_tag; print_open_tag = state.pp_print_open_tag; print_close_tag = state.pp_print_close_tag; } let pp_set_formatter_tag_functions state { mark_open_tag = mot; mark_close_tag = mct; print_open_tag = pot; print_close_tag = pct } = (state.pp_mark_open_tag <- mot; state.pp_mark_close_tag <- mct; state.pp_print_open_tag <- pot; state.pp_print_close_tag <- pct) (* Initialize pretty-printer. *) let pp_rinit state = (pp_clear_queue state; clear_scan_stack state; state.pp_format_stack <- []; state.pp_tbox_stack <- []; state.pp_tag_stack <- []; state.pp_mark_stack <- []; state.pp_current_indent <- 0; state.pp_curr_depth <- 0; state.pp_space_left <- state.pp_margin; pp_open_sys_box state) (* Flushing pretty-printer queue. *) let pp_flush_queue state b = (while state.pp_curr_depth > 1 do pp_close_box state () done; state.pp_right_total <- pp_infinity; advance_left state; if b then pp_output_newline state else (); pp_rinit state) (************************************************************** Procedures to format objects, and use boxes **************************************************************) (* To format a string. *) let pp_print_as_size state size s = if state.pp_curr_depth < state.pp_max_boxes then enqueue_string_as state size s else () let pp_print_as state isize s = pp_print_as_size state (size_of_int isize) s let pp_print_string state s = pp_print_as state (String.length s) s (* To format an integer. *) let pp_print_int state i = pp_print_string state (string_of_int i) (* To format a float. *) let pp_print_float state f = pp_print_string state (string_of_float f) (* To format a boolean. *) let pp_print_bool state b = pp_print_string state (string_of_bool b) (* To format a char. *) let pp_print_char state (c : char) = pp_print_as state 1 (string c) (* Opening boxes. *) let rec pp_open_hbox state () = pp_open_box_gen state 0 Pp_hbox and pp_open_vbox state indent = pp_open_box_gen state indent Pp_vbox and pp_open_hvbox state indent = pp_open_box_gen state indent Pp_hvbox and pp_open_hovbox state indent = pp_open_box_gen state indent Pp_hovbox and pp_open_box state indent = pp_open_box_gen state indent Pp_box (* Print a new line after printing all queued text (same for print_flush but without a newline). *) let rec pp_print_newline state () = pp_flush_queue state true state.pp_out_flush () and pp_print_flush state () = pp_flush_queue state false state.pp_out_flush () (* To get a newline when one does not want to close the current block. *) let pp_force_newline state () = if state.pp_curr_depth < state.pp_max_boxes then enqueue_advance state (make_queue_elem (size_of_int 0) Pp_newline 0) else () (* To format something if the line has just been broken. *) let pp_print_if_newline state () = if state.pp_curr_depth < state.pp_max_boxes then enqueue_advance state (make_queue_elem (size_of_int 0) Pp_if_newline 0) else () (* Breaks: indicate where a block may be broken. If line is broken then offset is added to the indentation of the current block else (the value of) width blanks are printed. To do (?) : add a maximum width and offset value. *) let pp_print_break state width offset = if state.pp_curr_depth < state.pp_max_boxes then (let elem = make_queue_elem (size_of_int (- state.pp_right_total)) (Pp_break (width, offset)) width in scan_push state true elem) else () let rec pp_print_space state () = pp_print_break state 1 0 and pp_print_cut state () = pp_print_break state 0 0 (* Tabulation boxes. *) let pp_open_tbox state () = (state.pp_curr_depth <- state.pp_curr_depth + 1; if state.pp_curr_depth < state.pp_max_boxes then (let elem = make_queue_elem (size_of_int 0) (Pp_tbegin (Pp_tbox (ref []))) 0 in enqueue_advance state elem) else ()) (* Close a tabulation block. *) let pp_close_tbox state () = if state.pp_curr_depth > 1 then if state.pp_curr_depth < state.pp_max_boxes then (let elem = make_queue_elem (size_of_int 0) Pp_tend 0 in (enqueue_advance state elem; state.pp_curr_depth <- state.pp_curr_depth - 1)) else () else () (* Print a tabulation break. *) let pp_print_tbreak state width offset = if state.pp_curr_depth < state.pp_max_boxes then (let elem = make_queue_elem (size_of_int (- state.pp_right_total)) (Pp_tbreak (width, offset)) width in scan_push state true elem) else () let pp_print_tab state () = pp_print_tbreak state 0 0 let pp_set_tab state () = if state.pp_curr_depth < state.pp_max_boxes then (let elem = make_queue_elem (size_of_int 0) Pp_stab 0 in enqueue_advance state elem) else () (************************************************************** Procedures to control the pretty-printers **************************************************************) (* Fit max_boxes. *) let pp_set_max_boxes state n = if n > 1 then state.pp_max_boxes <- n else () (* To know the current maximum number of boxes allowed. *) let pp_get_max_boxes state () = state.pp_max_boxes let pp_over_max_boxes state () = state.pp_curr_depth = state.pp_max_boxes (* Ellipsis. *) let rec pp_set_ellipsis_text state s = state.pp_ellipsis <- s and pp_get_ellipsis_text state () = state.pp_ellipsis (* To set the margin of pretty-printer. *) let pp_limit n = if n < pp_infinity then n else pred pp_infinity let pp_set_min_space_left state n = if n >= 1 then (let n = pp_limit n in (state.pp_min_space_left <- n; state.pp_max_indent <- state.pp_margin - state.pp_min_space_left; pp_rinit state)) else () (* Initially, we have : pp_max_indent = pp_margin - pp_min_space_left, and pp_space_left = pp_margin. *) let pp_set_max_indent state n = pp_set_min_space_left state (state.pp_margin - n) let pp_get_max_indent state () = state.pp_max_indent let pp_set_margin state n = if n >= 1 then (let n = pp_limit n in (state.pp_margin <- n; let new_max_indent = (* Try to maintain max_indent to its actual value. *) if state.pp_max_indent <= state.pp_margin then state.pp_max_indent else (* If possible maintain pp_min_space_left to its actual value, if this leads to a too small max_indent, take half of the new margin, if it is greater than 1. *) max (max (state.pp_margin - state.pp_min_space_left) (state.pp_margin / 2)) 1 in (* Rebuild invariants. *) pp_set_max_indent state new_max_indent)) else () let pp_get_margin state () = state.pp_margin type formatter_out_functions = { out_string : string -> int -> int -> unit; out_flush : unit -> unit; out_newline : unit -> unit; out_spaces : int -> unit } let pp_set_formatter_out_functions state { out_string = f; out_flush = g; out_newline = h; out_spaces = i } = state.pp_out_string <- f state.pp_out_flush <- g state.pp_out_newline <- h state.pp_out_spaces <- i let pp_get_formatter_out_functions state () = { out_string = state.pp_out_string; out_flush = state.pp_out_flush; out_newline = state.pp_out_newline; out_spaces = state.pp_out_spaces; } let pp_set_formatter_output_functions state f g = (state.pp_out_string <- f; state.pp_out_flush <- g) let pp_get_formatter_output_functions state () = state.pp_out_string, state.pp_out_flush //let pp_set_all_formatter_output_functions state ~out:f ~flush:g ~newline:h ~spaces:i = let pp_set_all_formatter_output_functions state f g h i = pp_set_formatter_output_functions state f g state.pp_out_newline <- h state.pp_out_spaces <- i let pp_get_all_formatter_output_functions state () = state.pp_out_string, state.pp_out_flush, state.pp_out_newline, state.pp_out_spaces (* Default function to output new lines. *) let display_newline state () = state.pp_out_string "\n" 0 1 (* Default function to output spaces. *) let blank_line = String.make 80 ' ' let rec display_blanks state n = if n > 0 then if n <= 80 then state.pp_out_string blank_line 0 n else (state.pp_out_string blank_line 0 80; display_blanks state (n - 80)) /// Re-implementation of OCaml's Pervasives.output, since the one in the /// F# compatibility library doesn't have the right type signature. let private output oc (buf : string) (pos : int) (len : int) = output_string oc (buf.Substring (pos, len)) let pp_set_formatter_out_channel state os = state.pp_out_string <- output os state.pp_out_flush <- (fun () -> flush os) state.pp_out_newline <- display_newline state state.pp_out_spaces <- display_blanks state (************************************************************** Creation of specific formatters **************************************************************) let default_pp_mark_open_tag s = "<" ^ (s ^ ">") let default_pp_mark_close_tag s = "") let default_pp_print_open_tag = ignore let default_pp_print_close_tag = ignore let pp_make_formatter f g h i = (* The initial state of the formatter contains a dummy box. *) let pp_q = make_queue () in let sys_tok = make_queue_elem (size_of_int (-1)) (Pp_begin (0, Pp_hovbox)) 0 in (add_queue sys_tok pp_q; let sys_scan_stack = (Scan_elem (1, sys_tok)) :: scan_stack_bottom in { pp_scan_stack = sys_scan_stack; pp_format_stack = []; pp_tbox_stack = []; pp_tag_stack = []; pp_mark_stack = []; pp_margin = 78; pp_min_space_left = 10; pp_max_indent = 78 - 10; pp_space_left = 78; pp_current_indent = 0; pp_is_new_line = true; pp_left_total = 1; pp_right_total = 1; pp_curr_depth = 1; pp_max_boxes = max_int; pp_ellipsis = "."; pp_out_string = f; pp_out_flush = g; pp_out_newline = h; pp_out_spaces = i; pp_print_tags = false; pp_mark_tags = false; pp_mark_open_tag = default_pp_mark_open_tag; pp_mark_close_tag = default_pp_mark_close_tag; pp_print_open_tag = default_pp_print_open_tag; pp_print_close_tag = default_pp_print_close_tag; pp_queue = pp_q; }) (* Make a formatter with default functions to output spaces and new lines. *) let make_formatter output flush = let ppf = pp_make_formatter output flush ignore ignore in (ppf.pp_out_newline <- display_newline ppf; ppf.pp_out_spaces <- display_blanks ppf; ppf) let formatter_of_out_channel oc = make_formatter (output oc) (fun () -> flush oc) let formatter_of_buffer b = make_formatter (Buffer.add_substring b) ignore let stdbuf = Buffer.create 512 (* Predefined formatters. *) let rec std_formatter = formatter_of_out_channel Pervasives.stdout and err_formatter = formatter_of_out_channel Pervasives.stderr and str_formatter = formatter_of_buffer stdbuf let flush_str_formatter () = (pp_flush_queue str_formatter false; let s = Buffer.contents stdbuf in (Buffer.reset stdbuf; s)) (************************************************************** Basic functions on the standard formatter **************************************************************) let rec open_hbox = pp_open_hbox std_formatter and open_vbox = pp_open_vbox std_formatter and open_hvbox = pp_open_hvbox std_formatter and open_hovbox = pp_open_hovbox std_formatter and open_box = pp_open_box std_formatter and close_box = pp_close_box std_formatter and open_tag = pp_open_tag std_formatter and close_tag = pp_close_tag std_formatter and print_as = pp_print_as std_formatter and print_string = pp_print_string std_formatter and print_int = pp_print_int std_formatter and print_float = pp_print_float std_formatter and print_char = pp_print_char std_formatter and print_bool = pp_print_bool std_formatter and print_break = pp_print_break std_formatter and print_cut = pp_print_cut std_formatter and print_space = pp_print_space std_formatter and force_newline = pp_force_newline std_formatter and print_flush = pp_print_flush std_formatter and print_newline = pp_print_newline std_formatter and print_if_newline = pp_print_if_newline std_formatter and open_tbox = pp_open_tbox std_formatter and close_tbox = pp_close_tbox std_formatter and print_tbreak = pp_print_tbreak std_formatter and set_tab = pp_set_tab std_formatter and print_tab = pp_print_tab std_formatter and set_margin = pp_set_margin std_formatter and get_margin = pp_get_margin std_formatter and set_max_indent = pp_set_max_indent std_formatter and get_max_indent = pp_get_max_indent std_formatter and set_max_boxes = pp_set_max_boxes std_formatter and get_max_boxes = pp_get_max_boxes std_formatter and over_max_boxes = pp_over_max_boxes std_formatter and set_ellipsis_text = pp_set_ellipsis_text std_formatter and get_ellipsis_text = pp_get_ellipsis_text std_formatter and set_formatter_out_channel (channel : out_channel) = pp_set_formatter_out_channel std_formatter channel and set_formatter_out_functions = pp_set_formatter_out_functions std_formatter and get_formatter_out_functions = pp_get_formatter_out_functions std_formatter and set_formatter_output_functions = pp_set_formatter_output_functions std_formatter and get_formatter_output_functions = pp_get_formatter_output_functions std_formatter and set_all_formatter_output_functions = pp_set_all_formatter_output_functions std_formatter and get_all_formatter_output_functions = pp_get_all_formatter_output_functions std_formatter and set_formatter_tag_functions = pp_set_formatter_tag_functions std_formatter and get_formatter_tag_functions = pp_get_formatter_tag_functions std_formatter and set_print_tags = pp_set_print_tags std_formatter and get_print_tags = pp_get_print_tags std_formatter and set_mark_tags = pp_set_mark_tags std_formatter and get_mark_tags = pp_get_mark_tags std_formatter and set_tags = pp_set_tags std_formatter (************************************************************** Printf implementation. **************************************************************) module Sformat = Printf.Sformat module Tformat = Printf.CamlinternalPr.Tformat (* Error messages when processing formats. *) (* Trailer: giving up at character number ... *) let giving_up mess fmt i = sprintf "Format.fprintf: %s ``%s'', giving up at character number %d%s" mess (Sformat.to_string fmt) i (if i < Sformat.length fmt then sprintf " (%c)." (Sformat.get fmt i) else sprintf "%c" '.') (* When an invalid format deserves a special error explanation. *) let format_invalid_arg mess fmt i = invalid_arg (giving_up mess fmt i) (* Standard invalid format. *) let invalid_format fmt i = format_invalid_arg "bad format" fmt i (* Cannot find a valid integer into that format. *) let invalid_integer fmt i = invalid_arg (giving_up "bad integer specification" fmt i) (* Finding an integer size out of a sub-string of the format. *) let format_int_of_string fmt i s = let sz = try int_of_string s with | Failure _ -> invalid_integer fmt i in size_of_int sz (* Getting strings out of buffers. *) let get_buffer_out b = let s = Buffer.contents b in (Buffer.reset b; s) (* [ppf] is supposed to be a pretty-printer that outputs to buffer [b]: to extract the contents of [ppf] as a string we flush [ppf] and get the string out of [b]. *) let string_out b ppf = (pp_flush_queue ppf false; get_buffer_out b) (* Applies [printer] to a formatter that outputs on a fresh buffer, then returns the resulting material. *) let exstring printer arg = let b = Buffer.create 512 in let ppf = formatter_of_buffer b in (printer ppf arg; string_out b ppf) (* To turn out a character accumulator into the proper string result. *) let implode_rev s0 = function | [] -> s0 | l -> String.concat "" (List.rev (s0 :: l)) (* [mkprintf] is the printf-like function generator: given the - [to_s] flag that tells if we are printing into a string, - the [get_out] function that has to be called to get a [ppf] function to output onto, it generates a [kprintf] function that takes as arguments a [k] continuation function to be called at the end of formatting, and a printing format string to print the rest of the arguments according to the format string. Regular [fprintf]-like functions of this module are obtained via partial applications of [mkprintf]. *) let mkprintf to_s get_out = let rec kprintf k fmt = let len = Sformat.length fmt in let kpr fmt v = let ppf = get_out fmt in let print_as = ref None in let rec pp_print_as_char c = match !print_as with | None -> pp_print_char ppf c | Some size -> (pp_print_as_size ppf size (String.make 1 c); print_as := None) and pp_print_as_string s = match !print_as with | None -> pp_print_string ppf s | Some size -> (pp_print_as_size ppf size s; print_as := None) in let rec doprn n i = if i >= len then Obj.magic (k ppf) else (match Sformat.get fmt i with | '%' -> Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m | '@' -> let i = succ i in if i >= len then invalid_format fmt i else (match Sformat.get fmt i with | '[' -> do_pp_open_box ppf n (succ i) | ']' -> (pp_close_box ppf (); doprn n (succ i)) | '{' -> do_pp_open_tag ppf n (succ i) | '}' -> (pp_close_tag ppf (); doprn n (succ i)) | ' ' -> (pp_print_space ppf (); doprn n (succ i)) | ',' -> (pp_print_cut ppf (); doprn n (succ i)) | '?' -> (pp_print_flush ppf (); doprn n (succ i)) | '.' -> (pp_print_newline ppf (); doprn n (succ i)) | '\n' -> (pp_force_newline ppf (); doprn n (succ i)) | ';' -> do_pp_break ppf n (succ i) | '<' -> let got_size size n i = (print_as := Some size; doprn n (skip_gt i)) in get_int n (succ i) got_size | ('@' | '%' as c) -> (pp_print_as_char c; doprn n (succ i)) | _ -> invalid_format fmt i) | c -> (pp_print_as_char c; doprn n (succ i))) and cont_s n s i = (pp_print_as_string s; doprn n i) and cont_a n printer arg i = (if to_s then pp_print_as_string ((Obj.magic printer : unit -> _ -> string) () arg) else printer ppf arg; doprn n i) and cont_t n printer i = (if to_s then pp_print_as_string ((Obj.magic printer : unit -> string) ()) else printer ppf; doprn n i) and cont_f n i = (pp_print_flush ppf (); doprn n i) and cont_m n sfmt i = kprintf (Obj.magic (fun _ -> doprn n i)) sfmt and get_int n i c = if i >= len then invalid_integer fmt i else (match Sformat.get fmt i with | ' ' -> get_int n (succ i) c | '%' -> let rec cont_s n s i = c (format_int_of_string fmt i s) n i and cont_a _n _printer _arg i = invalid_integer fmt i and cont_t _n _printer i = invalid_integer fmt i and cont_f _n i = invalid_integer fmt i and cont_m _n _sfmt i = invalid_integer fmt i in Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m | _ -> let rec get j = if j >= len then invalid_integer fmt j else (match Sformat.get fmt j with | x when x >= '0' && x <= '9' -> get (succ j) | '-' -> get (succ j) | _ -> let size = if j = i then size_of_int 0 else (let s = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in format_int_of_string fmt j s) in c size n j) in get i) and skip_gt i = if i >= len then invalid_format fmt i else (match Sformat.get fmt i with | ' ' -> skip_gt (succ i) | '>' -> succ i | _ -> invalid_format fmt i) and get_box_kind i = if i >= len then (Pp_box, i) else (match Sformat.get fmt i with | 'h' -> let i = succ i in if i >= len then (Pp_hbox, i) else (match Sformat.get fmt i with | 'o' -> let i = succ i in if i >= len then format_invalid_arg "bad box format" fmt i else (match Sformat.get fmt i with | 'v' -> (Pp_hovbox, (succ i)) | c -> format_invalid_arg ("bad box name ho" ^ (String.make 1 c)) fmt i) | 'v' -> (Pp_hvbox, (succ i)) | _ -> (Pp_hbox, i)) | 'b' -> (Pp_box, (succ i)) | 'v' -> (Pp_vbox, (succ i)) | _ -> (Pp_box, i)) and get_tag_name n i c = let rec get accu n i j = if j >= len then c (implode_rev (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) accu) n j else (match Sformat.get fmt j with | '>' -> c (implode_rev (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) accu) n j | '%' -> let s0 = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in let rec cont_s n s i = get (s :: s0 :: accu) n i i and cont_a n printer arg i = let s = if to_s then (Obj.magic printer : unit -> _ -> string) () arg else exstring printer arg in get (s :: s0 :: accu) n i i and cont_t n printer i = let s = if to_s then (Obj.magic printer : unit -> string) () else exstring (fun ppf () -> printer ppf) () in get (s :: s0 :: accu) n i i and cont_f _n i = format_invalid_arg "bad tag name specification" fmt i and cont_m _n _sfmt i = format_invalid_arg "bad tag name specification" fmt i in Tformat.scan_format fmt v n j cont_s cont_a cont_t cont_f cont_m | _ -> get accu n i (succ j)) in get [] n i i and do_pp_break ppf n i = if i >= len then (pp_print_space ppf (); doprn n i) else (match Sformat.get fmt i with | '<' -> let rec got_nspaces nspaces n i = get_int n i (got_offset nspaces) and got_offset nspaces offset n i = (pp_print_break ppf (int_of_size nspaces) (int_of_size offset); doprn n (skip_gt i)) in get_int n (succ i) got_nspaces | _c -> (pp_print_space ppf (); doprn n i)) and do_pp_open_box ppf n i = if i >= len then (pp_open_box_gen ppf 0 Pp_box; doprn n i) else (match Sformat.get fmt i with | '<' -> let (kind, i) = get_box_kind (succ i) in let got_size size n i = (pp_open_box_gen ppf (int_of_size size) kind; doprn n (skip_gt i)) in get_int n i got_size | _c -> (pp_open_box_gen ppf 0 Pp_box; doprn n i)) and do_pp_open_tag ppf n i = if i >= len then (pp_open_tag ppf ""; doprn n i) else (match Sformat.get fmt i with | '<' -> let got_name tag_name n i = (pp_open_tag ppf tag_name; doprn n (skip_gt i)) in get_tag_name n (succ i) got_name | _c -> (pp_open_tag ppf ""; doprn n i)) in doprn (Sformat.index_of_int 0) 0 in Tformat.kapr kpr fmt in kprintf (************************************************************** Defining [fprintf] and various flavors of [fprintf]. **************************************************************) let kfprintf k ppf = mkprintf false (fun _ -> ppf) k let ikfprintf k ppf = Tformat.kapr (fun _ _ -> Obj.magic (k ppf)) let fprintf ppf = kfprintf ignore ppf let ifprintf ppf = ikfprintf ignore ppf let printf fmt = fprintf std_formatter fmt let eprintf fmt = fprintf err_formatter fmt let ksprintf k = let b = Buffer.create 512 in let k ppf = k (string_out b ppf) in mkprintf true (fun _ -> formatter_of_buffer b) k let sprintf fmt = ksprintf (fun s -> s) fmt (************************************************************** Deprecated stuff. **************************************************************) let kbprintf k b = mkprintf false (fun _ -> formatter_of_buffer b) k (* Deprecated error prone function bprintf. *) let bprintf b = let k ppf = pp_flush_queue ppf false in kbprintf k b (* Deprecated alias for ksprintf. *) let kprintf = ksprintf (* Output everything left in the pretty printer queue at end of execution. *) let _ = at_exit print_flush ================================================ FILE: test/apps/FSharp.Compatibility/Format.fs.faceup ================================================ «x:(* OCaml Compatibility Library for F# (Format module) (FSharp.Compatibility.OCaml.Format) Copyright (c) 1996 Institut National de Recherche en Informatique et en Automatique Copyright (c) Jack Pappas 2012 http://github.com/jack-pappas This code is distributed under the terms of the GNU Lesser General Public License (LGPL) v2.1. See the LICENSE file for details. *)» «m:// »«x:References: »«m:// »«x:http://caml.inria.fr/pub/docs/manual-ocaml/libref/Format.html » «m:/// »«x:Pretty printing. »[] «k:module» «t:FSharp.Compatibility.OCaml.Format» «x:(************************************************************** Data structures definitions. **************************************************************)» «m:// »«x:TODO : Recreate 'size' as a measure type on int »«k:type» «t:size» = int «k:let» «k:inline» «f:size_of_int» («v:n» : «t:int») : «t:size» = n «k:let» «k:inline» «f:int_of_size» («v:s» : «t:size») : «t:int» = s «x:(* Tokens are one of the following : *)» «k:type» «t:pp_token» = «x:(* normal text *)» «:fsharp-ui-operator-face:|» Pp_text «k:of» string «x:(* complete break *)» «:fsharp-ui-operator-face:|» Pp_break «k:of» int * int «x:(* go to next tabulation *)» «:fsharp-ui-operator-face:|» Pp_tbreak «k:of» int * int «x:(* set a tabulation *)» «:fsharp-ui-operator-face:|» Pp_stab «x:(* beginning of a block *)» «:fsharp-ui-operator-face:|» Pp_begin «k:of» int * block_type «x:(* end of a block *)» «:fsharp-ui-operator-face:|» Pp_end «x:(* beginning of a tabulation block *)» «:fsharp-ui-operator-face:|» Pp_tbegin «k:of» tblock «x:(* end of a tabulation block *)» «:fsharp-ui-operator-face:|» Pp_tend «x:(* to force a newline inside a block *)» «:fsharp-ui-operator-face:|» Pp_newline «x:(* to do something only if this very line has been broken *)» «:fsharp-ui-operator-face:|» Pp_if_newline «x:(* opening a tag name *)» «:fsharp-ui-operator-face:|» Pp_open_tag «k:of» tag «x:(* closing the most recently opened tag *)» «:fsharp-ui-operator-face:|» Pp_close_tag «k:and» «v:tag» = string «k:and» «v:block_type» = «x:(* Horizontal block no line breaking *)» «:fsharp-ui-operator-face:|» Pp_hbox «x:(* Vertical block each break leads to a new line *)» «:fsharp-ui-operator-face:|» Pp_vbox «x:(* Horizontal-vertical block: same as vbox, except if this block is small enough to fit on a single line *)» «:fsharp-ui-operator-face:|» Pp_hvbox «x:(* Horizontal or Vertical block: breaks lead to new line only when necessary to print the content of the block *)» «:fsharp-ui-operator-face:|» Pp_hovbox «x:(* Horizontal or Indent block: breaks lead to new line only when necessary to print the content of the block, or when it leads to a new indentation of the current line *)» «:fsharp-ui-operator-face:|» Pp_box «x:(* Internal usage: when a block fits on a single line *)» «:fsharp-ui-operator-face:|» Pp_fits «k:and» «v:tblock» = «x:(* Tabulation box *)» «:fsharp-ui-operator-face:|» Pp_tbox «k:of» (int list) ref «x:(* The Queue: contains all formatting elements. elements are tuples (size, token, length), where size is set when the size of the block is known len is the declared length of the token. *)» «k:type» «t:pp_queue_elem» = { «k:mutable» elem_size : «t:size»; token : «t:pp_token»; length : «t:int»; } «x:(* Scan stack: each element is (left_total, queue element) where left_total is the value of pp_left_total when the element has been enqueued. *)» «k:type» «t:pp_scan_elem» = «:fsharp-ui-operator-face:|» Scan_elem «k:of» int * pp_queue_elem «x:(* Formatting stack: used to break the lines while printing tokens. The formatting stack contains the description of the currently active blocks. *)» «k:type» «t:pp_format_elem» = «:fsharp-ui-operator-face:|» Format_elem «k:of» block_type * int «x:(* General purpose queues, used in the formatter. *)» «k:type» «t:'a» «v:queue_elem» = «:fsharp-ui-operator-face:|» Nil «:fsharp-ui-operator-face:|» Cons «k:of» 'a queue_cell «k:and» «f:'a» «v:queue_cell» = { «k:mutable» head : 'a; «k:mutable» tail : 'a queue_elem; } «k:type» «t:'a» «v:queue» = { «k:mutable» insert : 'a queue_elem; «k:mutable» body : 'a queue_elem; } «x:(* The formatter specific tag handling functions. *)» «k:type» «t:formatter_tag_functions» = { mark_open_tag : «t:tag» -> string; mark_close_tag : «t:tag» -> string; print_open_tag : «t:tag» -> unit; print_close_tag : «t:tag» -> unit; } «x:(* A formatter with all its machinery. *)» «k:type» «t:formatter» = { «k:mutable» pp_scan_stack : «t:pp_scan_elem list»; «k:mutable» pp_format_stack : «t:pp_format_elem list»; «k:mutable» pp_tbox_stack : «t:tblock list»; «k:mutable» pp_tag_stack : «t:tag list»; «k:mutable» pp_mark_stack : «t:tag list»; «x:(* Global variables: default initialization is set_margin 78 set_min_space_left 0. *)» «m:/// »«x:Value of right margin. » «k:mutable» pp_margin : «t:int»; «m:/// »«x:Minimal space left before margin, when opening a block. » «k:mutable» pp_min_space_left : «t:int»; «m:/// »«x:Maximum value of indentation: no blocks can be opened further. » «k:mutable» pp_max_indent : «t:int»; «m:/// »«x:Space remaining on the current line. » «k:mutable» pp_space_left : «t:int»; «m:/// »«x:Current value of indentation. » «k:mutable» pp_current_indent : «t:int»; «m:/// »«x:True when the line has been broken by the pretty-printer. » «k:mutable» pp_is_new_line : «t:bool»; «m:/// »«x:Total width of tokens already printed. » «k:mutable» pp_left_total : «t:int»; «m:/// »«x:Total width of tokens ever put in queue. » «k:mutable» pp_right_total : «t:int»; «m:/// »«x:Current number of opened blocks. » «k:mutable» pp_curr_depth : «t:int»; «m:/// »«x:Maximum number of blocks which can be simultaneously opened. » «k:mutable» pp_max_boxes : «t:int»; «m:/// »«x:Ellipsis string. » «k:mutable» pp_ellipsis : «t:string»; «m:/// »«x:Output function. » «k:mutable» pp_out_string : «t:string» -> int -> int -> unit; «m:/// »«x:Flushing function. » «k:mutable» pp_out_flush : «t:unit» -> unit; «m:/// »«x:Output of new lines. » «k:mutable» pp_out_newline : «t:unit» -> unit; «m:/// »«x:Output of indentation spaces. » «k:mutable» pp_out_spaces : «t:int» -> unit; «m:/// »«x:Are tags printed? » «k:mutable» pp_print_tags : «t:bool»; «m:/// »«x:Are tags marked? » «k:mutable» pp_mark_tags : «t:bool»; «m:/// »«x:Find opening and closing markers of tags. » «k:mutable» pp_mark_open_tag : «t:tag» -> string; «k:mutable» pp_mark_close_tag : «t:tag» -> string; «k:mutable» pp_print_open_tag : «t:tag» -> unit; «k:mutable» pp_print_close_tag : «t:tag» -> unit; «m:/// »«x:The pretty-printer queue. » «k:mutable» pp_queue : «t:pp_queue_elem queue» } «x:(************************************************************** Auxilliaries and basic functions. **************************************************************)» «m:/// »«x:Queues auxilliaries. »«k:let» «f:make_queue» () = { insert = Nil; body = Nil; } «k:let» «f:clear_queue» «v:q» = q.insert <- Nil q.body <- Nil «k:let» «f:add_queue» «v:x» «v:q» = «k:let» «v:c» = Cons { head = x; tail = Nil; } «k:match» q «k:with» «:fsharp-ui-operator-face:|» { insert = Cons cell; body = _ } -> (q.insert <- c; cell.tail <- c) «:fsharp-ui-operator-face:|» «x:(* Invariant: when insert is Nil body should be Nil. *)» { insert = Nil; body = _ } -> (q.insert <- c; q.body <- c) «k:exception» Empty_queue «k:let» «v:peek_queue» = «k:function» «:fsharp-ui-operator-face:|» { body = Cons { head = x; tail = _ }; insert = _ } -> x «:fsharp-ui-operator-face:|» { body = Nil; insert = _ } -> raise Empty_queue «k:let» «v:take_queue» = «k:function» «:fsharp-ui-operator-face:|» ({ body = Cons { head = x; tail = tl }; insert = _ } «k:as» q) -> (q.body <- tl; «k:if» tl = Nil «k:then» q.insert <- Nil «k:else» (); «x:(* Maintain the invariant. *)» x) «:fsharp-ui-operator-face:|» { body = Nil; insert = _ } -> raise Empty_queue «x:(* Enter a token in the pretty-printer queue. *)» «k:let» «f:pp_enqueue» «v:state» (({ «v:length» = len; elem_size = _; token = _ } «k:as» token)) = state.pp_right_total <- state.pp_right_total + len add_queue token state.pp_queue «k:let» «f:pp_clear_queue» «v:state» = state.pp_left_total <- 1 state.pp_right_total <- 1 clear_queue state.pp_queue «x:(* Pp_infinity: large value for default tokens size. Pp_infinity is documented as being greater than 1e10; to avoid confusion about the word ``greater'', we choose pp_infinity greater than 1e10 + 1; for correct handling of tests in the algorithm, pp_infinity must be even one more than 1e10 + 1; let's stand on the safe side by choosing 1.e10+10. Pp_infinity could probably be 1073741823 that is 2^30 - 1, that is the minimal upper bound for integers; now that max_int is defined, this limit could also be defined as max_int - 1. However, before setting pp_infinity to something around max_int, we must carefully double-check all the integer arithmetic operations that involve pp_infinity, since any overflow would wreck havoc the pretty-printing algorithm's invariants. Given that this arithmetic correctness check is difficult and error prone and given that 1e10 + 1 is in practice large enough, there is no need to attempt to set pp_infinity to the theoretically maximum limit. It is not worth the burden ! *)» «k:let» «v:pp_infinity» = 1000000010 «x:(* Output functions for the formatter. *)» «k:let» «k:rec» «f:pp_output_string» «v:state» «v:s» = state.pp_out_string s 0 (String.length s) «k:and» «f:pp_output_newline» «v:state» = state.pp_out_newline () «k:and» «f:pp_output_spaces» «v:state» «v:n» = state.pp_out_spaces n «x:(* To format a break, indenting a new line. *)» «k:let» «f:break_new_line» «v:state» «v:offset» «v:width» = (pp_output_newline state; state.pp_is_new_line <- «k:true»; «k:let» «v:indent» = (state.pp_margin - width) + offset «k:in» «x:(* Don't indent more than pp_max_indent. *)» «k:let» «v:real_indent» = min state.pp_max_indent indent «k:in» (state.pp_current_indent <- real_indent; state.pp_space_left <- state.pp_margin - state.pp_current_indent; pp_output_spaces state state.pp_current_indent)) «x:(* To force a line break inside a block: no offset is added. *)» «k:let» «f:break_line» «v:state» «v:width» = break_new_line state 0 width «x:(* To format a break that fits on the current line. *)» «k:let» «f:break_same_line» «v:state» «v:width» = (state.pp_space_left <- state.pp_space_left - width; pp_output_spaces state width) «x:(* To indent no more than pp_max_indent, if one tries to open a block beyond pp_max_indent, then the block is rejected on the left by simulating a break. *)» «k:let» «f:pp_force_break_line» «v:state» = «k:match» state.pp_format_stack «k:with» «:fsharp-ui-operator-face:|» Format_elem (bl_ty, width) :: _ -> «k:if» width > state.pp_space_left «k:then» («k:match» bl_ty «k:with» «:fsharp-ui-operator-face:|» Pp_fits -> () «:fsharp-ui-operator-face:|» Pp_hbox -> () «:fsharp-ui-operator-face:|» Pp_vbox «:fsharp-ui-operator-face:|» Pp_hvbox «:fsharp-ui-operator-face:|» Pp_hovbox «:fsharp-ui-operator-face:|» Pp_box -> break_line state width) «k:else» () «:fsharp-ui-operator-face:|» [] -> pp_output_newline state «x:(* To skip a token, if the previous line has been broken. *)» «k:let» «f:pp_skip_token» «v:state» = «x:(* When calling pp_skip_token the queue cannot be empty. *)» «k:match» take_queue state.pp_queue «k:with» «:fsharp-ui-operator-face:|» { elem_size = size; length = len; token = _ } -> (state.pp_left_total <- state.pp_left_total - len; state.pp_space_left <- state.pp_space_left + (int_of_size size)) «x:(************************************************************** The main pretty printing functions. **************************************************************)» «x:(* To format a token. *)» «k:let» «f:format_pp_token» «v:state» «v:size» = «k:function» «:fsharp-ui-operator-face:|» Pp_text s -> (state.pp_space_left <- state.pp_space_left - size; pp_output_string state s; state.pp_is_new_line <- «k:false») «:fsharp-ui-operator-face:|» Pp_begin (off, ty) -> «k:let» «v:insertion_point» = state.pp_margin - state.pp_space_left «k:in» («k:if» insertion_point > state.pp_max_indent «k:then» «x:(* can't open a block right there. *)» pp_force_break_line state «k:else» (); «k:let» «v:offset» = state.pp_space_left - off «k:in» «k:let» «v:bl_type» = («k:match» ty «k:with» «:fsharp-ui-operator-face:|» Pp_vbox -> Pp_vbox «:fsharp-ui-operator-face:|» Pp_hbox «:fsharp-ui-operator-face:|» Pp_hvbox «:fsharp-ui-operator-face:|» Pp_hovbox «:fsharp-ui-operator-face:|» Pp_box «:fsharp-ui-operator-face:|» Pp_fits -> «k:if» size > state.pp_space_left «k:then» ty «k:else» Pp_fits) «k:in» state.pp_format_stack <- (Format_elem (bl_type, offset)) :: state.pp_format_stack) «:fsharp-ui-operator-face:|» Pp_end -> («k:match» state.pp_format_stack «k:with» «:fsharp-ui-operator-face:|» _ :: ls -> state.pp_format_stack <- ls «:fsharp-ui-operator-face:|» [] -> ()) «:fsharp-ui-operator-face:|» «x:(* No more block to close. *)» Pp_tbegin ((Pp_tbox _ «k:as» tbox)) -> state.pp_tbox_stack <- tbox :: state.pp_tbox_stack «:fsharp-ui-operator-face:|» Pp_tend -> («k:match» state.pp_tbox_stack «k:with» «:fsharp-ui-operator-face:|» _ :: ls -> state.pp_tbox_stack <- ls «:fsharp-ui-operator-face:|» [] -> ()) «:fsharp-ui-operator-face:|» «x:(* No more tabulation block to close. *)» Pp_stab -> («k:match» state.pp_tbox_stack «k:with» «:fsharp-ui-operator-face:|» Pp_tbox tabs :: _ -> «k:let» «k:rec» «f:add_tab» «v:n» = («k:function» «:fsharp-ui-operator-face:|» [] -> [ n ] «:fsharp-ui-operator-face:|» (x :: l «k:as» ls) -> «k:if» n < x «k:then» n :: ls «k:else» x :: (add_tab n l)) «k:in» tabs := add_tab (state.pp_margin - state.pp_space_left) !tabs «:fsharp-ui-operator-face:|» [] -> ()) «:fsharp-ui-operator-face:|» «x:(* No opened tabulation block. *)» Pp_tbreak (n, off) -> «k:let» «v:insertion_point» = state.pp_margin - state.pp_space_left «k:in» («k:match» state.pp_tbox_stack «k:with» «:fsharp-ui-operator-face:|» Pp_tbox tabs :: _ -> «k:let» «k:rec» «f:find» «v:n» = («k:function» «:fsharp-ui-operator-face:|» x :: l -> «k:if» x >= n «k:then» x «k:else» find n l «:fsharp-ui-operator-face:|» [] -> raise Not_found) «k:in» «k:let» «v:tab» = («k:match» !tabs «k:with» «:fsharp-ui-operator-face:|» x :: _ -> («k:try» find insertion_point !tabs «k:with» «:fsharp-ui-operator-face:|» Not_found -> x) «:fsharp-ui-operator-face:|» _ -> insertion_point) «k:in» «k:let» «v:offset» = tab - insertion_point «k:in» «k:if» offset >= 0 «k:then» break_same_line state (offset + n) «k:else» break_new_line state (tab + off) state.pp_margin «:fsharp-ui-operator-face:|» [] -> ()) «:fsharp-ui-operator-face:|» «x:(* No opened tabulation block. *)» Pp_newline -> («k:match» state.pp_format_stack «k:with» «:fsharp-ui-operator-face:|» Format_elem (_, width) :: _ -> break_line state width «:fsharp-ui-operator-face:|» [] -> pp_output_newline state) «:fsharp-ui-operator-face:|» «x:(* No opened block. *)» Pp_if_newline -> «k:if» state.pp_current_indent <> (state.pp_margin - state.pp_space_left) «k:then» pp_skip_token state «:fsharp-ui-operator-face:|» Pp_break (n, off) -> («k:match» state.pp_format_stack «k:with» «:fsharp-ui-operator-face:|» Format_elem (ty, width) :: _ -> («k:match» ty «k:with» «:fsharp-ui-operator-face:|» Pp_hovbox -> «k:if» size > state.pp_space_left «k:then» break_new_line state off width «k:else» break_same_line state n «:fsharp-ui-operator-face:|» Pp_box -> «x:(* Have the line just been broken here ? *)» «k:if» state.pp_is_new_line «k:then» break_same_line state n «k:else» «k:if» size > state.pp_space_left «k:then» break_new_line state off width «k:else» «x:(* break the line here leads to new indentation ? *)» «k:if» state.pp_current_indent > ((state.pp_margin - width) + off) «k:then» break_new_line state off width «k:else» break_same_line state n «:fsharp-ui-operator-face:|» Pp_hvbox -> break_new_line state off width «:fsharp-ui-operator-face:|» Pp_fits -> break_same_line state n «:fsharp-ui-operator-face:|» Pp_vbox -> break_new_line state off width «:fsharp-ui-operator-face:|» Pp_hbox -> break_same_line state n) «:fsharp-ui-operator-face:|» [] -> ()) «:fsharp-ui-operator-face:|» «x:(* No opened block. *)» Pp_open_tag tag_name -> «k:let» «v:marker» = state.pp_mark_open_tag tag_name «k:in» (pp_output_string state marker; state.pp_mark_stack <- tag_name :: state.pp_mark_stack) «:fsharp-ui-operator-face:|» Pp_close_tag -> («k:match» state.pp_mark_stack «k:with» «:fsharp-ui-operator-face:|» tag_name :: tags -> «k:let» «v:marker» = state.pp_mark_close_tag tag_name «k:in» (pp_output_string state marker; state.pp_mark_stack <- tags) «:fsharp-ui-operator-face:|» [] -> ()) «x:(* No more tag to close. *)» «x:(* Print if token size is known or printing is delayed. Size is known when not negative. Printing is delayed when the text waiting in the queue requires more room to format than exists on the current line. Note: [advance_loop] must be tail recursive to prevent stack overflows. *)» «k:let» «k:rec» «f:advance_loop» «v:state» = «k:match» peek_queue state.pp_queue «k:with» «:fsharp-ui-operator-face:|» { elem_size = size; token = tok; length = len } -> «k:let» «v:size» = int_of_size size «k:in» «k:if» «k:not» ((size < 0) && ((state.pp_right_total - state.pp_left_total) < state.pp_space_left)) «k:then» (ignore (take_queue state.pp_queue); format_pp_token state («k:if» size < 0 «k:then» pp_infinity «k:else» size) tok; state.pp_left_total <- len + state.pp_left_total; advance_loop state) «k:else» () «k:let» «f:advance_left» «v:state» = «k:try» advance_loop state «k:with» «:fsharp-ui-operator-face:|» Empty_queue -> () «k:let» «f:enqueue_advance» «v:state» «v:tok» = (pp_enqueue state tok; advance_left state) «x:(* To enqueue a string : try to advance. *)» «k:let» «f:make_queue_elem» «v:size» «v:tok» «v:len» = { elem_size = size; token = tok; length = len; } «k:let» «f:enqueue_string_as» «v:state» «v:size» «v:s» = «k:let» «v:len» = int_of_size size «k:in» enqueue_advance state (make_queue_elem size (Pp_text s) len) «k:let» «f:enqueue_string» «v:state» «v:s» = «k:let» «v:len» = String.length s «k:in» enqueue_string_as state (size_of_int len) s «x:(* Routines for scan stack determine sizes of blocks. *)» «x:(* The scan_stack is never empty. *)» «k:let» «v:scan_stack_bottom» = «k:let» «v:q_elem» = make_queue_elem (size_of_int (-1)) (Pp_text «s:""») 0 «k:in» [ Scan_elem ((-1), q_elem) ] «x:(* Set size of blocks on scan stack: if ty = true then size of break is set else size of block is set; in each case pp_scan_stack is popped. *)» «k:let» «f:clear_scan_stack» «v:state» = state.pp_scan_stack <- scan_stack_bottom «x:(* Pattern matching on scan stack is exhaustive, since scan_stack is never empty. Pattern matching on token in scan stack is also exhaustive, since scan_push is used on breaks and opening of boxes. *)» «k:let» «f:set_size» «v:state» «v:ty» = «k:match» state.pp_scan_stack «k:with» «:fsharp-ui-operator-face:|» Scan_elem (left_tot, (({ elem_size = size; token = tok; length = _ } «k:as» queue_elem))) :: t -> «k:let» «v:size» = int_of_size size «k:in» «x:(* test if scan stack contains any data that is not obsolete. *)» «k:if» left_tot < state.pp_left_total «k:then» clear_scan_stack state «k:else» («k:match» tok «k:with» «:fsharp-ui-operator-face:|» Pp_break (_, _) «:fsharp-ui-operator-face:|» Pp_tbreak (_, _) -> «k:if» ty «k:then» (queue_elem.elem_size <- size_of_int (state.pp_right_total + size); state.pp_scan_stack <- t) «k:else» () «:fsharp-ui-operator-face:|» Pp_begin (_, _) -> «k:if» «k:not» ty «k:then» (queue_elem.elem_size <- size_of_int (state.pp_right_total + size); state.pp_scan_stack <- t) «k:else» () «:fsharp-ui-operator-face:|» Pp_text _ «:fsharp-ui-operator-face:|» Pp_stab «:fsharp-ui-operator-face:|» Pp_tbegin _ «:fsharp-ui-operator-face:|» Pp_tend «:fsharp-ui-operator-face:|» Pp_end | Pp_newline «:fsharp-ui-operator-face:|» Pp_if_newline «:fsharp-ui-operator-face:|» Pp_open_tag _ «:fsharp-ui-operator-face:|» Pp_close_tag -> ()) «:fsharp-ui-operator-face:|» «x:(* scan_push is only used for breaks and boxes. *)» [] -> () «x:(* scan_stack is never empty. *)» «x:(* Push a token on scan stack. If b is true set_size is called. *)» «k:let» «f:scan_push» «v:state» «v:b» «v:tok» = (pp_enqueue state tok; «k:if» b «k:then» set_size state «k:true» «k:else» (); state.pp_scan_stack <- (Scan_elem (state.pp_right_total, tok)) :: state.pp_scan_stack) «x:(* To open a new block : the user may set the depth bound pp_max_boxes any text nested deeper is printed as the ellipsis string. *)» «k:let» «f:pp_open_box_gen» «v:state» «v:indent» «v:br_ty» = (state.pp_curr_depth <- state.pp_curr_depth + 1; «k:if» state.pp_curr_depth < state.pp_max_boxes «k:then» («k:let» elem = make_queue_elem (size_of_int (- state.pp_right_total)) (Pp_begin (indent, br_ty)) 0 «k:in» scan_push state «k:false» elem) «k:else» «k:if» state.pp_curr_depth = state.pp_max_boxes «k:then» enqueue_string state state.pp_ellipsis «k:else» ()) «x:(* The box which is always opened. *)» «k:let» «f:pp_open_sys_box» «v:state» = pp_open_box_gen state 0 Pp_hovbox «x:(* Close a block, setting sizes of its sub blocks. *)» «k:let» «f:pp_close_box» «v:state» () = «k:if» state.pp_curr_depth > 1 «k:then» («k:if» state.pp_curr_depth < state.pp_max_boxes «k:then» (pp_enqueue state { elem_size = size_of_int 0; token = Pp_end; length = 0; }; set_size state «k:true»; set_size state «k:false») «k:else» (); state.pp_curr_depth <- state.pp_curr_depth - 1) «k:else» () «x:(* Open a tag, pushing it on the tag stack. *)» «k:let» «f:pp_open_tag» «v:state» «v:tag_name» = («k:if» state.pp_print_tags «k:then» (state.pp_tag_stack <- tag_name :: state.pp_tag_stack; state.pp_print_open_tag tag_name) «k:else» (); «k:if» state.pp_mark_tags «k:then» pp_enqueue state { elem_size = size_of_int 0; token = Pp_open_tag tag_name; length = 0; } «k:else» ()) «x:(* Close a tag, popping it from the tag stack. *)» «k:let» «f:pp_close_tag» «v:state» () = («k:if» state.pp_mark_tags «k:then» pp_enqueue state { elem_size = size_of_int 0; token = Pp_close_tag; length = 0; } «k:else» (); «k:if» state.pp_print_tags «k:then» («k:match» state.pp_tag_stack «k:with» «:fsharp-ui-operator-face:|» tag_name :: tags -> (state.pp_print_close_tag tag_name; state.pp_tag_stack <- tags) «:fsharp-ui-operator-face:|» _ -> ()) «k:else» ()) «x:(* No more tag to close. *)» «k:let» «f:pp_set_print_tags» «v:state» «v:b» = state.pp_print_tags <- b «k:let» «f:pp_set_mark_tags» «v:state» «v:b» = state.pp_mark_tags <- b «k:let» «f:pp_get_print_tags» «v:state» () = state.pp_print_tags «k:let» «f:pp_get_mark_tags» «v:state» () = state.pp_mark_tags «k:let» «f:pp_set_tags» «v:state» «v:b» = (pp_set_print_tags state b; pp_set_mark_tags state b) «k:let» «f:pp_get_formatter_tag_functions» «v:state» () = { mark_open_tag = state.pp_mark_open_tag; mark_close_tag = state.pp_mark_close_tag; print_open_tag = state.pp_print_open_tag; print_close_tag = state.pp_print_close_tag; } «k:let» «f:pp_set_formatter_tag_functions» «v:state» { «v:mark_open_tag» = mot; mark_close_tag = mct; print_open_tag = pot; print_close_tag = pct } = (state.pp_mark_open_tag <- mot; state.pp_mark_close_tag <- mct; state.pp_print_open_tag <- pot; state.pp_print_close_tag <- pct) «x:(* Initialize pretty-printer. *)» «k:let» «f:pp_rinit» «v:state» = (pp_clear_queue state; clear_scan_stack state; state.pp_format_stack <- []; state.pp_tbox_stack <- []; state.pp_tag_stack <- []; state.pp_mark_stack <- []; state.pp_current_indent <- 0; state.pp_curr_depth <- 0; state.pp_space_left <- state.pp_margin; pp_open_sys_box state) «x:(* Flushing pretty-printer queue. *)» «k:let» «f:pp_flush_queue» «v:state» «v:b» = («k:while» state.pp_curr_depth > 1 «k:do» pp_close_box state () «k:done»; state.pp_right_total <- pp_infinity; advance_left state; «k:if» b «k:then» pp_output_newline state «k:else» (); pp_rinit state) «x:(************************************************************** Procedures to format objects, and use boxes **************************************************************)» «x:(* To format a string. *)» «k:let» «f:pp_print_as_size» «v:state» «v:size» «v:s» = «k:if» state.pp_curr_depth < state.pp_max_boxes «k:then» enqueue_string_as state size s «k:else» () «k:let» «f:pp_print_as» «v:state» «v:isize» «v:s» = pp_print_as_size state (size_of_int isize) s «k:let» «f:pp_print_string» «v:state» «v:s» = pp_print_as state (String.length s) s «x:(* To format an integer. *)» «k:let» «f:pp_print_int» «v:state» «v:i» = pp_print_string state (string_of_int i) «x:(* To format a float. *)» «k:let» «f:pp_print_float» «v:state» «v:f» = pp_print_string state (string_of_float f) «x:(* To format a boolean. *)» «k:let» «f:pp_print_bool» «v:state» «v:b» = pp_print_string state (string_of_bool b) «x:(* To format a char. *)» «k:let» «f:pp_print_char» «v:state» («v:c» : «t:char») = pp_print_as state 1 (string c) «x:(* Opening boxes. *)» «k:let» «k:rec» «f:pp_open_hbox» «v:state» () = pp_open_box_gen state 0 Pp_hbox «k:and» «f:pp_open_vbox» «v:state» «v:indent» = pp_open_box_gen state indent Pp_vbox «k:and» «f:pp_open_hvbox» «v:state» «v:indent» = pp_open_box_gen state indent Pp_hvbox «k:and» «f:pp_open_hovbox» «v:state» «v:indent» = pp_open_box_gen state indent Pp_hovbox «k:and» «f:pp_open_box» «v:state» «v:indent» = pp_open_box_gen state indent Pp_box «x:(* Print a new line after printing all queued text (same for print_flush but without a newline). *)» «k:let» «k:rec» «f:pp_print_newline» «v:state» () = pp_flush_queue state «k:true» state.pp_out_flush () «k:and» «f:pp_print_flush» «v:state» () = pp_flush_queue state «k:false» state.pp_out_flush () «x:(* To get a newline when one does not want to close the current block. *)» «k:let» «f:pp_force_newline» «v:state» () = «k:if» state.pp_curr_depth < state.pp_max_boxes «k:then» enqueue_advance state (make_queue_elem (size_of_int 0) Pp_newline 0) «k:else» () «x:(* To format something if the line has just been broken. *)» «k:let» «f:pp_print_if_newline» «v:state» () = «k:if» state.pp_curr_depth < state.pp_max_boxes «k:then» enqueue_advance state (make_queue_elem (size_of_int 0) Pp_if_newline 0) «k:else» () «x:(* Breaks: indicate where a block may be broken. If line is broken then offset is added to the indentation of the current block else (the value of) width blanks are printed. To do (?) : add a maximum width and offset value. *)» «k:let» «f:pp_print_break» «v:state» «v:width» «v:offset» = «k:if» state.pp_curr_depth < state.pp_max_boxes «k:then» («k:let» elem = make_queue_elem (size_of_int (- state.pp_right_total)) (Pp_break (width, offset)) width «k:in» scan_push state «k:true» elem) «k:else» () «k:let» «k:rec» «f:pp_print_space» «v:state» () = pp_print_break state 1 0 «k:and» «f:pp_print_cut» «v:state» () = pp_print_break state 0 0 «x:(* Tabulation boxes. *)» «k:let» «f:pp_open_tbox» «v:state» () = (state.pp_curr_depth <- state.pp_curr_depth + 1; «k:if» state.pp_curr_depth < state.pp_max_boxes «k:then» («k:let» elem = make_queue_elem (size_of_int 0) (Pp_tbegin (Pp_tbox (ref []))) 0 «k:in» enqueue_advance state elem) «k:else» ()) «x:(* Close a tabulation block. *)» «k:let» «f:pp_close_tbox» «v:state» () = «k:if» state.pp_curr_depth > 1 «k:then» «k:if» state.pp_curr_depth < state.pp_max_boxes «k:then» («k:let» elem = make_queue_elem (size_of_int 0) Pp_tend 0 «k:in» (enqueue_advance state elem; state.pp_curr_depth <- state.pp_curr_depth - 1)) «k:else» () «k:else» () «x:(* Print a tabulation break. *)» «k:let» «f:pp_print_tbreak» «v:state» «v:width» «v:offset» = «k:if» state.pp_curr_depth < state.pp_max_boxes «k:then» («k:let» elem = make_queue_elem (size_of_int (- state.pp_right_total)) (Pp_tbreak (width, offset)) width «k:in» scan_push state «k:true» elem) «k:else» () «k:let» «f:pp_print_tab» «v:state» () = pp_print_tbreak state 0 0 «k:let» «f:pp_set_tab» «v:state» () = «k:if» state.pp_curr_depth < state.pp_max_boxes «k:then» («k:let» elem = make_queue_elem (size_of_int 0) Pp_stab 0 «k:in» enqueue_advance state elem) «k:else» () «x:(************************************************************** Procedures to control the pretty-printers **************************************************************)» «x:(* Fit max_boxes. *)» «k:let» «f:pp_set_max_boxes» «v:state» «v:n» = «k:if» n > 1 «k:then» state.pp_max_boxes <- n «k:else» () «x:(* To know the current maximum number of boxes allowed. *)» «k:let» «f:pp_get_max_boxes» «v:state» () = state.pp_max_boxes «k:let» «f:pp_over_max_boxes» «v:state» () = state.pp_curr_depth = state.pp_max_boxes «x:(* Ellipsis. *)» «k:let» «k:rec» «f:pp_set_ellipsis_text» «v:state» «v:s» = state.pp_ellipsis <- s «k:and» «f:pp_get_ellipsis_text» «v:state» () = state.pp_ellipsis «x:(* To set the margin of pretty-printer. *)» «k:let» «f:pp_limit» «v:n» = «k:if» n < pp_infinity «k:then» n «k:else» pred pp_infinity «k:let» «f:pp_set_min_space_left» «v:state» «v:n» = «k:if» n >= 1 «k:then» («k:let» n = pp_limit n «k:in» (state.pp_min_space_left <- n; state.pp_max_indent <- state.pp_margin - state.pp_min_space_left; pp_rinit state)) «k:else» () «x:(* Initially, we have : pp_max_indent = pp_margin - pp_min_space_left, and pp_space_left = pp_margin. *)» «k:let» «f:pp_set_max_indent» «v:state» «v:n» = pp_set_min_space_left state (state.pp_margin - n) «k:let» «f:pp_get_max_indent» «v:state» () = state.pp_max_indent «k:let» «f:pp_set_margin» «v:state» «v:n» = «k:if» n >= 1 «k:then» («k:let» n = pp_limit n «k:in» (state.pp_margin <- n; «k:let» «v:new_max_indent» = «x:(* Try to maintain max_indent to its actual value. *)» «k:if» state.pp_max_indent <= state.pp_margin «k:then» state.pp_max_indent «k:else» «x:(* If possible maintain pp_min_space_left to its actual value, if this leads to a too small max_indent, take half of the new margin, if it is greater than 1. *)» max (max (state.pp_margin - state.pp_min_space_left) (state.pp_margin / 2)) 1 «k:in» «x:(* Rebuild invariants. *)» pp_set_max_indent state new_max_indent)) «k:else» () «k:let» «f:pp_get_margin» «v:state» () = state.pp_margin «k:type» «t:formatter_out_functions» = { out_string : «t:string» -> int -> int -> unit; out_flush : «t:unit» -> unit; out_newline : «t:unit» -> unit; out_spaces : «t:int» -> unit } «k:let» «f:pp_set_formatter_out_functions» «v:state» { «v:out_string» = f; out_flush = g; out_newline = h; out_spaces = i } = state.pp_out_string <- f state.pp_out_flush <- g state.pp_out_newline <- h state.pp_out_spaces <- i «k:let» «f:pp_get_formatter_out_functions» «v:state» () = { out_string = state.pp_out_string; out_flush = state.pp_out_flush; out_newline = state.pp_out_newline; out_spaces = state.pp_out_spaces; } «k:let» «f:pp_set_formatter_output_functions» «v:state» «v:f» «v:g» = (state.pp_out_string <- f; state.pp_out_flush <- g) «k:let» «f:pp_get_formatter_output_functions» «v:state» () = state.pp_out_string, state.pp_out_flush «m://»«x:let pp_set_all_formatter_output_functions state ~out:f ~flush:g ~newline:h ~spaces:i = »«k:let» «f:pp_set_all_formatter_output_functions» «v:state» «v:f» «v:g» «v:h» «v:i» = pp_set_formatter_output_functions state f g state.pp_out_newline <- h state.pp_out_spaces <- i «k:let» «f:pp_get_all_formatter_output_functions» «v:state» () = state.pp_out_string, state.pp_out_flush, state.pp_out_newline, state.pp_out_spaces «x:(* Default function to output new lines. *)» «k:let» «f:display_newline» «v:state» () = state.pp_out_string «s:"\n"» 0 1 «x:(* Default function to output spaces. *)» «k:let» «v:blank_line» = String.make 80 «s:' '» «k:let» «k:rec» «f:display_blanks» «v:state» «v:n» = «k:if» n > 0 «k:then» «k:if» n <= 80 «k:then» state.pp_out_string blank_line 0 n «k:else» (state.pp_out_string blank_line 0 80; display_blanks state (n - 80)) «m:/// »«x:Re-implementation of OCaml's Pervasives.output, since the one in the »«m:/// »«x:F# compatibility library doesn't have the right type signature. »«k:let» «k:private» «f:output» «v:oc» («v:buf» : «t:string») («v:pos» : «t:int») («v:len» : «t:int») = output_string oc (buf.Substring (pos, len)) «k:let» «f:pp_set_formatter_out_channel» «v:state» «v:os» = state.pp_out_string <- output os state.pp_out_flush <- («k:fun» () -> flush os) state.pp_out_newline <- display_newline state state.pp_out_spaces <- display_blanks state «x:(************************************************************** Creation of specific formatters **************************************************************)» «k:let» «f:default_pp_mark_open_tag» «v:s» = «s:"<"» ^ (s ^ «s:">"») «k:let» «f:default_pp_mark_close_tag» «v:s» = «s:""») «k:let» «v:default_pp_print_open_tag» = ignore «k:let» «v:default_pp_print_close_tag» = ignore «k:let» «f:pp_make_formatter» «v:f» «v:g» «v:h» «v:i» = «x:(* The initial state of the formatter contains a dummy box. *)» «k:let» «v:pp_q» = make_queue () «k:in» «k:let» «v:sys_tok» = make_queue_elem (size_of_int (-1)) (Pp_begin (0, Pp_hovbox)) 0 «k:in» (add_queue sys_tok pp_q; «k:let» «v:sys_scan_stack» = (Scan_elem (1, sys_tok)) :: scan_stack_bottom «k:in» { pp_scan_stack = sys_scan_stack; pp_format_stack = []; pp_tbox_stack = []; pp_tag_stack = []; pp_mark_stack = []; pp_margin = 78; pp_min_space_left = 10; pp_max_indent = 78 - 10; pp_space_left = 78; pp_current_indent = 0; pp_is_new_line = «k:true»; pp_left_total = 1; pp_right_total = 1; pp_curr_depth = 1; pp_max_boxes = max_int; pp_ellipsis = «s:"."»; pp_out_string = f; pp_out_flush = g; pp_out_newline = h; pp_out_spaces = i; pp_print_tags = «k:false»; pp_mark_tags = «k:false»; pp_mark_open_tag = default_pp_mark_open_tag; pp_mark_close_tag = default_pp_mark_close_tag; pp_print_open_tag = default_pp_print_open_tag; pp_print_close_tag = default_pp_print_close_tag; pp_queue = pp_q; }) «x:(* Make a formatter with default functions to output spaces and new lines. *)» «k:let» «f:make_formatter» «v:output» «v:flush» = «k:let» «v:ppf» = pp_make_formatter output flush ignore ignore «k:in» (ppf.pp_out_newline <- display_newline ppf; ppf.pp_out_spaces <- display_blanks ppf; ppf) «k:let» «f:formatter_of_out_channel» «v:oc» = make_formatter (output oc) («k:fun» () -> flush oc) «k:let» «f:formatter_of_buffer» «v:b» = make_formatter (Buffer.add_substring b) ignore «k:let» «v:stdbuf» = Buffer.create 512 «x:(* Predefined formatters. *)» «k:let» «k:rec» «v:std_formatter» = formatter_of_out_channel Pervasives.stdout «k:and» «v:err_formatter» = formatter_of_out_channel Pervasives.stderr «k:and» «v:str_formatter» = formatter_of_buffer stdbuf «k:let» «f:flush_str_formatter» () = (pp_flush_queue str_formatter «k:false»; «k:let» «v:s» = Buffer.contents stdbuf «k:in» (Buffer.reset stdbuf; s)) «x:(************************************************************** Basic functions on the standard formatter **************************************************************)» «k:let» «k:rec» «v:open_hbox» = pp_open_hbox std_formatter «k:and» «v:open_vbox» = pp_open_vbox std_formatter «k:and» «v:open_hvbox» = pp_open_hvbox std_formatter «k:and» «v:open_hovbox» = pp_open_hovbox std_formatter «k:and» «v:open_box» = pp_open_box std_formatter «k:and» «v:close_box» = pp_close_box std_formatter «k:and» «v:open_tag» = pp_open_tag std_formatter «k:and» «v:close_tag» = pp_close_tag std_formatter «k:and» «v:print_as» = pp_print_as std_formatter «k:and» «v:print_string» = pp_print_string std_formatter «k:and» «v:print_int» = pp_print_int std_formatter «k:and» «v:print_float» = pp_print_float std_formatter «k:and» «v:print_char» = pp_print_char std_formatter «k:and» «v:print_bool» = pp_print_bool std_formatter «k:and» «v:print_break» = pp_print_break std_formatter «k:and» «v:print_cut» = pp_print_cut std_formatter «k:and» «v:print_space» = pp_print_space std_formatter «k:and» «v:force_newline» = pp_force_newline std_formatter «k:and» «v:print_flush» = pp_print_flush std_formatter «k:and» «v:print_newline» = pp_print_newline std_formatter «k:and» «v:print_if_newline» = pp_print_if_newline std_formatter «k:and» «v:open_tbox» = pp_open_tbox std_formatter «k:and» «v:close_tbox» = pp_close_tbox std_formatter «k:and» «v:print_tbreak» = pp_print_tbreak std_formatter «k:and» «v:set_tab» = pp_set_tab std_formatter «k:and» «v:print_tab» = pp_print_tab std_formatter «k:and» «v:set_margin» = pp_set_margin std_formatter «k:and» «v:get_margin» = pp_get_margin std_formatter «k:and» «v:set_max_indent» = pp_set_max_indent std_formatter «k:and» «v:get_max_indent» = pp_get_max_indent std_formatter «k:and» «v:set_max_boxes» = pp_set_max_boxes std_formatter «k:and» «v:get_max_boxes» = pp_get_max_boxes std_formatter «k:and» «v:over_max_boxes» = pp_over_max_boxes std_formatter «k:and» «v:set_ellipsis_text» = pp_set_ellipsis_text std_formatter «k:and» «v:get_ellipsis_text» = pp_get_ellipsis_text std_formatter «k:and» «f:set_formatter_out_channel» («v:channel» : «t:out_channel») = pp_set_formatter_out_channel std_formatter channel «k:and» «v:set_formatter_out_functions» = pp_set_formatter_out_functions std_formatter «k:and» «v:get_formatter_out_functions» = pp_get_formatter_out_functions std_formatter «k:and» «v:set_formatter_output_functions» = pp_set_formatter_output_functions std_formatter «k:and» «v:get_formatter_output_functions» = pp_get_formatter_output_functions std_formatter «k:and» «v:set_all_formatter_output_functions» = pp_set_all_formatter_output_functions std_formatter «k:and» «v:get_all_formatter_output_functions» = pp_get_all_formatter_output_functions std_formatter «k:and» «v:set_formatter_tag_functions» = pp_set_formatter_tag_functions std_formatter «k:and» «v:get_formatter_tag_functions» = pp_get_formatter_tag_functions std_formatter «k:and» «v:set_print_tags» = pp_set_print_tags std_formatter «k:and» «v:get_print_tags» = pp_get_print_tags std_formatter «k:and» «v:set_mark_tags» = pp_set_mark_tags std_formatter «k:and» «v:get_mark_tags» = pp_get_mark_tags std_formatter «k:and» «v:set_tags» = pp_set_tags std_formatter «x:(************************************************************** Printf implementation. **************************************************************)» «k:module» «t:Sformat» = Printf.Sformat «k:module» «t:Tformat» = Printf.CamlinternalPr.Tformat «x:(* Error messages when processing formats. *)» «x:(* Trailer: giving up at character number ... *)» «k:let» «f:giving_up» «v:mess» «v:fmt» «v:i» = sprintf «s:"Format.fprintf: %s ``%s'', giving up at character number %d%s"» mess (Sformat.to_string fmt) i («k:if» i < Sformat.length fmt «k:then» sprintf «s:" (%c)."» (Sformat.get fmt i) «k:else» sprintf «s:"%c"» «s:'.'») «x:(* When an invalid format deserves a special error explanation. *)» «k:let» «f:format_invalid_arg» «v:mess» «v:fmt» «v:i» = invalid_arg (giving_up mess fmt i) «x:(* Standard invalid format. *)» «k:let» «f:invalid_format» «v:fmt» «v:i» = format_invalid_arg «s:"bad format"» fmt i «x:(* Cannot find a valid integer into that format. *)» «k:let» «f:invalid_integer» «v:fmt» «v:i» = invalid_arg (giving_up «s:"bad integer specification"» fmt i) «x:(* Finding an integer size out of a sub-string of the format. *)» «k:let» «f:format_int_of_string» «v:fmt» «v:i» «v:s» = «k:let» «v:sz» = «k:try» int_of_string s «k:with» «:fsharp-ui-operator-face:|» Failure _ -> invalid_integer fmt i «k:in» size_of_int sz «x:(* Getting strings out of buffers. *)» «k:let» «f:get_buffer_out» «v:b» = «k:let» s = Buffer.contents b «k:in» (Buffer.reset b; s) «x:(* [ppf] is supposed to be a pretty-printer that outputs to buffer [b]: to extract the contents of [ppf] as a string we flush [ppf] and get the string out of [b]. *)» «k:let» «f:string_out» «v:b» «v:ppf» = (pp_flush_queue ppf «k:false»; get_buffer_out b) «x:(* Applies [printer] to a formatter that outputs on a fresh buffer, then returns the resulting material. *)» «k:let» «f:exstring» «v:printer» «v:arg» = «k:let» «v:b» = Buffer.create 512 «k:in» «k:let» «v:ppf» = formatter_of_buffer b «k:in» (printer ppf arg; string_out b ppf) «x:(* To turn out a character accumulator into the proper string result. *)» «k:let» «f:implode_rev» «v:s0» = «k:function» «:fsharp-ui-operator-face:|» [] -> s0 «:fsharp-ui-operator-face:|» l -> String.concat «s:""» (List.rev (s0 :: l)) «x:(* [mkprintf] is the printf-like function generator: given the - [to_s] flag that tells if we are printing into a string, - the [get_out] function that has to be called to get a [ppf] function to output onto, it generates a [kprintf] function that takes as arguments a [k] continuation function to be called at the end of formatting, and a printing format string to print the rest of the arguments according to the format string. Regular [fprintf]-like functions of this module are obtained via partial applications of [mkprintf]. *)» «k:let» «f:mkprintf» «v:to_s» «v:get_out» = «k:let» «k:rec» «f:kprintf» «v:k» «v:fmt» = «k:let» «v:len» = Sformat.length fmt «k:in» «k:let» «f:kpr» «v:fmt» «v:v» = «k:let» «v:ppf» = get_out fmt «k:in» «k:let» «v:print_as» = ref None «k:in» «k:let» «k:rec» «f:pp_print_as_char» «v:c» = «k:match» !print_as «k:with» «:fsharp-ui-operator-face:|» None -> pp_print_char ppf c «:fsharp-ui-operator-face:|» Some size -> (pp_print_as_size ppf size (String.make 1 c); print_as := None) «k:and» «f:pp_print_as_string» «v:s» = «k:match» !print_as «k:with» «:fsharp-ui-operator-face:|» None -> pp_print_string ppf s «:fsharp-ui-operator-face:|» Some size -> (pp_print_as_size ppf size s; print_as := None) «k:in» «k:let» «k:rec» «f:doprn» «v:n» «v:i» = «k:if» i >= len «k:then» Obj.magic (k ppf) «k:else» («k:match» Sformat.get fmt i «k:with» «:fsharp-ui-operator-face:|» «s:'%'» -> Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m «:fsharp-ui-operator-face:|» «s:'@'» -> «k:let» «v:i» = succ i «k:in» «k:if» i >= len «k:then» invalid_format fmt i «k:else» («k:match» Sformat.get fmt i «k:with» «:fsharp-ui-operator-face:|» «s:'['» -> do_pp_open_box ppf n (succ i) «:fsharp-ui-operator-face:|» «s:']'» -> (pp_close_box ppf (); doprn n (succ i)) «:fsharp-ui-operator-face:|» «s:'{'» -> do_pp_open_tag ppf n (succ i) «:fsharp-ui-operator-face:|» «s:'}'» -> (pp_close_tag ppf (); doprn n (succ i)) «:fsharp-ui-operator-face:|» «s:' '» -> (pp_print_space ppf (); doprn n (succ i)) «:fsharp-ui-operator-face:|» «s:','» -> (pp_print_cut ppf (); doprn n (succ i)) «:fsharp-ui-operator-face:|» «s:'?'» -> (pp_print_flush ppf (); doprn n (succ i)) «:fsharp-ui-operator-face:|» «s:'.'» -> (pp_print_newline ppf (); doprn n (succ i)) «:fsharp-ui-operator-face:|» «s:'\n'» -> (pp_force_newline ppf (); doprn n (succ i)) «:fsharp-ui-operator-face:|» «s:';'» -> do_pp_break ppf n (succ i) «:fsharp-ui-operator-face:|» «s:'<'» -> «k:let» «f:got_size» «v:size» «v:n» «v:i» = (print_as := Some size; doprn n (skip_gt i)) «k:in» get_int n (succ i) got_size «:fsharp-ui-operator-face:|» («s:'@'» «:fsharp-ui-operator-face:|» «s:'%'» «k:as» c) -> (pp_print_as_char c; doprn n (succ i)) «:fsharp-ui-operator-face:|» _ -> invalid_format fmt i) «:fsharp-ui-operator-face:|» c -> (pp_print_as_char c; doprn n (succ i))) «k:and» «f:cont_s» «v:n» «v:s» «v:i» = (pp_print_as_string s; doprn n i) «k:and» «f:cont_a» «v:n» «v:printer» «v:arg» «v:i» = («k:if» to_s «k:then» pp_print_as_string ((Obj.magic printer : «t:unit» -> _ -> string) () arg) «k:else» printer ppf arg; doprn n i) «k:and» «f:cont_t» «v:n» «v:printer» «v:i» = («k:if» to_s «k:then» pp_print_as_string ((Obj.magic printer : «t:unit» -> string) ()) «k:else» printer ppf; doprn n i) «k:and» «f:cont_f» «v:n» «v:i» = (pp_print_flush ppf (); doprn n i) «k:and» «f:cont_m» «v:n» «v:sfmt» «v:i» = kprintf (Obj.magic («k:fun» «v:_» -> doprn n i)) sfmt «k:and» «f:get_int» «v:n» «v:i» «v:c» = «k:if» i >= len «k:then» invalid_integer fmt i «k:else» («k:match» Sformat.get fmt i «k:with» «:fsharp-ui-operator-face:|» «s:' '» -> get_int n (succ i) c «:fsharp-ui-operator-face:|» «s:'%'» -> «k:let» «k:rec» «f:cont_s» «v:n» «v:s» «v:i» = c (format_int_of_string fmt i s) n i «k:and» «f:cont_a» «v:_n» «v:_printer» «v:_arg» «v:i» = invalid_integer fmt i «k:and» «f:cont_t» «v:_n» «v:_printer» «v:i» = invalid_integer fmt i «k:and» «f:cont_f» «v:_n» «v:i» = invalid_integer fmt i «k:and» «f:cont_m» «v:_n» «v:_sfmt» «v:i» = invalid_integer fmt i «k:in» Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m «:fsharp-ui-operator-face:|» _ -> «k:let» «k:rec» «f:get» «v:j» = «k:if» j >= len «k:then» invalid_integer fmt j «k:else» («k:match» Sformat.get fmt j «k:with» «:fsharp-ui-operator-face:|» x «k:when» x >= «s:'0'» && x <= «s:'9'» -> get (succ j) «:fsharp-ui-operator-face:|» «s:'-'» -> get (succ j) «:fsharp-ui-operator-face:|» _ -> «k:let» «v:size» = «k:if» j = i «k:then» size_of_int 0 «k:else» («k:let» s = Sformat.sub fmt (Sformat.index_of_int i) (j - i) «k:in» format_int_of_string fmt j s) «k:in» c size n j) «k:in» get i) «k:and» «f:skip_gt» «v:i» = «k:if» i >= len «k:then» invalid_format fmt i «k:else» («k:match» Sformat.get fmt i «k:with» «:fsharp-ui-operator-face:|» «s:' '» -> skip_gt (succ i) «:fsharp-ui-operator-face:|» «s:'>'» -> succ i «:fsharp-ui-operator-face:|» _ -> invalid_format fmt i) «k:and» «f:get_box_kind» «v:i» = «k:if» i >= len «k:then» (Pp_box, i) «k:else» («k:match» Sformat.get fmt i «k:with» «:fsharp-ui-operator-face:|» «s:'h'» -> «k:let» «v:i» = succ i «k:in» «k:if» i >= len «k:then» (Pp_hbox, i) «k:else» («k:match» Sformat.get fmt i «k:with» «:fsharp-ui-operator-face:|» «s:'o'» -> «k:let» «v:i» = succ i «k:in» «k:if» i >= len «k:then» format_invalid_arg «s:"bad box format"» fmt i «k:else» («k:match» Sformat.get fmt i «k:with» «:fsharp-ui-operator-face:|» «s:'v'» -> (Pp_hovbox, (succ i)) «:fsharp-ui-operator-face:|» c -> format_invalid_arg («s:"bad box name ho"» ^ (String.make 1 c)) fmt i) «:fsharp-ui-operator-face:|» «s:'v'» -> (Pp_hvbox, (succ i)) «:fsharp-ui-operator-face:|» _ -> (Pp_hbox, i)) «:fsharp-ui-operator-face:|» «s:'b'» -> (Pp_box, (succ i)) «:fsharp-ui-operator-face:|» «s:'v'» -> (Pp_vbox, (succ i)) «:fsharp-ui-operator-face:|» _ -> (Pp_box, i)) «k:and» «f:get_tag_name» «v:n» «v:i» «v:c» = «k:let» «k:rec» «f:get» «v:accu» «v:n» «v:i» «v:j» = «k:if» j >= len «k:then» c (implode_rev (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) accu) n j «k:else» («k:match» Sformat.get fmt j «k:with» «:fsharp-ui-operator-face:|» «s:'>'» -> c (implode_rev (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) accu) n j «:fsharp-ui-operator-face:|» «s:'%'» -> «k:let» «v:s0» = Sformat.sub fmt (Sformat.index_of_int i) (j - i) «k:in» «k:let» «k:rec» «f:cont_s» «v:n» «v:s» «v:i» = get (s :: s0 :: accu) n i i «k:and» «f:cont_a» «v:n» «v:printer» «v:arg» «v:i» = «k:let» «v:s» = «k:if» to_s «k:then» (Obj.magic printer : «t:unit» -> _ -> string) () arg «k:else» exstring printer arg «k:in» get (s :: s0 :: accu) n i i «k:and» «f:cont_t» «v:n» «v:printer» «v:i» = «k:let» «v:s» = «k:if» to_s «k:then» (Obj.magic printer : «t:unit» -> string) () «k:else» exstring («k:fun» «v:ppf» () -> printer ppf) () «k:in» get (s :: s0 :: accu) n i i «k:and» «f:cont_f» «v:_n» «v:i» = format_invalid_arg «s:"bad tag name specification"» fmt i «k:and» «f:cont_m» «v:_n» «v:_sfmt» «v:i» = format_invalid_arg «s:"bad tag name specification"» fmt i «k:in» Tformat.scan_format fmt v n j cont_s cont_a cont_t cont_f cont_m «:fsharp-ui-operator-face:|» _ -> get accu n i (succ j)) «k:in» get [] n i i «k:and» «f:do_pp_break» «v:ppf» «v:n» «v:i» = «k:if» i >= len «k:then» (pp_print_space ppf (); doprn n i) «k:else» («k:match» Sformat.get fmt i «k:with» «:fsharp-ui-operator-face:|» «s:'<'» -> «k:let» «k:rec» «f:got_nspaces» «v:nspaces» «v:n» «v:i» = get_int n i (got_offset nspaces) «k:and» «f:got_offset» «v:nspaces» «v:offset» «v:n» «v:i» = (pp_print_break ppf (int_of_size nspaces) (int_of_size offset); doprn n (skip_gt i)) «k:in» get_int n (succ i) got_nspaces «:fsharp-ui-operator-face:|» _c -> (pp_print_space ppf (); doprn n i)) «k:and» «f:do_pp_open_box» «v:ppf» «v:n» «v:i» = «k:if» i >= len «k:then» (pp_open_box_gen ppf 0 Pp_box; doprn n i) «k:else» («k:match» Sformat.get fmt i «k:with» «:fsharp-ui-operator-face:|» «s:'<'» -> «k:let» («v:kind», «v:i») = get_box_kind (succ i) «k:in» «k:let» «f:got_size» «v:size» «v:n» «v:i» = (pp_open_box_gen ppf (int_of_size size) kind; doprn n (skip_gt i)) «k:in» get_int n i got_size «:fsharp-ui-operator-face:|» _c -> (pp_open_box_gen ppf 0 Pp_box; doprn n i)) «k:and» «f:do_pp_open_tag» «v:ppf» «v:n» «v:i» = «k:if» i >= len «k:then» (pp_open_tag ppf «s:""»; doprn n i) «k:else» («k:match» Sformat.get fmt i «k:with» «:fsharp-ui-operator-face:|» «s:'<'» -> «k:let» «f:got_name» «v:tag_name» «v:n» «v:i» = (pp_open_tag ppf tag_name; doprn n (skip_gt i)) «k:in» get_tag_name n (succ i) got_name «:fsharp-ui-operator-face:|» _c -> (pp_open_tag ppf «s:""»; doprn n i)) «k:in» doprn (Sformat.index_of_int 0) 0 «k:in» Tformat.kapr kpr fmt «k:in» kprintf «x:(************************************************************** Defining [fprintf] and various flavors of [fprintf]. **************************************************************)» «k:let» «f:kfprintf» «v:k» «v:ppf» = mkprintf «k:false» («k:fun» «v:_» -> ppf) k «k:let» «f:ikfprintf» «v:k» «v:ppf» = Tformat.kapr («k:fun» «v:_» «v:_» -> Obj.magic (k ppf)) «k:let» «f:fprintf» «v:ppf» = kfprintf ignore ppf «k:let» «f:ifprintf» «v:ppf» = ikfprintf ignore ppf «k:let» «f:printf» «v:fmt» = fprintf std_formatter fmt «k:let» «f:eprintf» «v:fmt» = fprintf err_formatter fmt «k:let» «f:ksprintf» «v:k» = «k:let» «v:b» = Buffer.create 512 «k:in» «k:let» «f:k» «v:ppf» = k (string_out b ppf) «k:in» mkprintf «k:true» («k:fun» «v:_» -> formatter_of_buffer b) k «k:let» «f:sprintf» «v:fmt» = ksprintf («k:fun» «v:s» -> s) fmt «x:(************************************************************** Deprecated stuff. **************************************************************)» «k:let» «f:kbprintf» «v:k» «v:b» = mkprintf «k:false» («k:fun» «v:_» -> formatter_of_buffer b) k «x:(* Deprecated error prone function bprintf. *)» «k:let» «f:bprintf» «v:b» = «k:let» «f:k» ppf = pp_flush_queue ppf «k:false» «k:in» kbprintf k b «x:(* Deprecated alias for ksprintf. *)» «k:let» «v:kprintf» = ksprintf «x:(* Output everything left in the pretty printer queue at end of execution. *)» «k:let» «v:_» = at_exit print_flush ================================================ FILE: test/apps/RecordHighlighting/Test.fsx ================================================ type RecordTest1 = { something: int another: string } type RecordTest2 = { something :int; another :string } type RecordTest3 = { something : float; another: float; third :float; } type RecordTest4 = { something: int another: string } type RecordTest5 = { something: int another: string } type RecordTest6 = { something: int another: string third: Option } type RecordTest7 = { something: int another: string third: int option } ================================================ FILE: test/apps/RecordHighlighting/Test.fsx.faceup ================================================ «k:type» «t:RecordTest1» = { something: «t:int» another: «t:string» } «k:type» «t:RecordTest2» = { something :«t:int»; another :«t:string» } «k:type» «t:RecordTest3» = { something : «t:float»; another: «t:float»; third :«t:float»; } «k:type» «t:RecordTest4» = { something: «t:int» another: «t:string» } «k:type» «t:RecordTest5» = { something: «t:int» another: «t:string» } «k:type» «t:RecordTest6» = { something: «t:int» another: «t:string» third: «t:Option»«:fsharp-ui-generic-face:» } «k:type» «t:RecordTest7» = { something: «t:int» another: «t:string» third: «t:int option» } ================================================ FILE: test/eglot-fsharp-integration-util.el ================================================ ;;; eglot-fsharp-integration-util.el --- Helper for eglot integration tests -*- lexical-binding: t; -*- ;; Copyright (C) 2022-2023 Jürgen Hötzel ;; Author: Jürgen Hötzel ;; Keywords: processes ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . ;;; Commentary: ;; ;;; Code: (require 'edebug) (cl-defmacro eglot-fsharp--with-timeout (timeout &body body) (declare (indent 1) (debug t)) `(eglot-fsharp--call-with-timeout ,timeout (lambda () ,@body))) (defun eglot-fsharp--call-with-timeout (timeout fn) (let* ((tag (gensym "eglot-test-timeout")) (timed-out (make-symbol "timeout")) (timeout-and-message (if (listp timeout) timeout (list timeout "waiting for test to finish"))) (timeout (car timeout-and-message)) (message (cadr timeout-and-message)) (timer) (retval)) (unwind-protect (setq retval (catch tag (setq timer (run-with-timer timeout nil (lambda () (unless edebug-active (throw tag timed-out))))) (funcall fn))) (cancel-timer timer) (when (eq retval timed-out) (warn "Received Events for %s : %s" (file-name-nondirectory (buffer-file-name)) (with-current-buffer (jsonrpc-events-buffer (eglot-current-server)) (buffer-string))) (error "%s" (concat "Timed out " message)))))) (defun eglot-fsharp--find-file-noselect (file &optional noerror) (unless (or noerror (file-readable-p file)) (error "%s does not exist" file)) (find-file-noselect file)) (defun eglot-fsharp--tests-connect (&optional timeout) (let* ((timeout (or timeout 10)) (eglot-sync-connect t) (eglot-connect-timeout timeout)) (apply #'eglot--connect (eglot--guess-contact)))) (cl-defmacro eglot-fsharp--wait-for ((events-sym &optional (timeout 1) message) args &body body) "Spin until FN match in EVENTS-SYM, flush events after it. Pass TIMEOUT to `eglot--with-timeout'." (declare (indent 2) (debug (sexp sexp sexp &rest form))) `(eglot-fsharp--with-timeout '(,timeout ,(or message (format "waiting for:\n%s" (pp-to-string body)))) (let ((event (cl-loop thereis (cl-loop for json in ,events-sym for method = (plist-get json :method) when (keywordp method) do (plist-put json :method (substring (symbol-name method) 1)) when (funcall (jsonrpc-lambda ,args ,@body) json) return (cons json before) collect json into before) for i from 0 when (zerop (mod i 5)) ;; do (eglot--message "still struggling to find in %s" ;; ,events-sym) do ;; `read-event' is essential to have the file ;; watchers come through. (read-event "[eglot] Waiting a bit..." nil 0.1) (accept-process-output nil 0.1)))) (setq ,events-sym (cdr event)) (eglot--message "Event detected:\n%s" (pp-to-string (car event)))))) (cl-defmacro eglot-fsharp--sniffing ((&key server-requests server-notifications server-replies client-requests client-notifications client-replies) &rest body) "Run BODY saving LSP JSON messages in variables, most recent first." (declare (indent 1) (debug (sexp &rest form))) (let ((log-event-ad-sym (make-symbol "eglot-fsharp--event-sniff"))) `(unwind-protect (let ,(delq nil (list server-requests server-notifications server-replies client-requests client-notifications client-replies)) (advice-add #'jsonrpc--log-event :before (lambda (_proc message &optional type) (cl-destructuring-bind (&key method id _error &allow-other-keys) message (let ((req-p (and method id)) (notif-p method) (reply-p id)) (cond ((eq type 'server) (cond (req-p ,(when server-requests `(push message ,server-requests))) (notif-p ,(when server-notifications `(push message ,server-notifications))) (reply-p ,(when server-replies `(push message ,server-replies))))) ((eq type 'client) (cond (req-p ,(when client-requests `(push message ,client-requests))) (notif-p ,(when client-notifications `(push message ,client-notifications))) (reply-p ,(when client-replies `(push message ,client-replies))))))))) '((name . ,log-event-ad-sym))) ,@body) (advice-remove #'jsonrpc--log-event ',log-event-ad-sym)))) (defun eglot-fsharp--sniff-diagnostics (file-name-suffix) (eglot-fsharp--sniffing (:server-notifications s-notifs) (eglot-fsharp--wait-for (s-notifs 20) (&key _id method params &allow-other-keys) (and (string= method "textDocument/publishDiagnostics") (string-suffix-p file-name-suffix (plist-get params :uri)))))) (defun eglot-fsharp--sniff-method (method-name) (eglot-fsharp--sniffing (:server-notifications s-notifs) (eglot-fsharp--wait-for (s-notifs 20) (&key _id method params &allow-other-keys) (and (string= method method-name))))) (provide 'eglot-fsharp-integration-util) ;;; integration-util.el ends here ================================================ FILE: test/expression.fsx ================================================ 1 + 1;; ================================================ FILE: test/fsharp-mode-font-tests.el ================================================ ;;; fsharp-mode-font-tests.el --- -*- lexical-binding: t; -*- (require 'buttercup) (require 'fsharp-mode) (defmacro with-highlighted (src &rest body) "Insert SRC in a temporary fsharp-mode buffer, apply syntax highlighting, then run BODY." `(with-temp-buffer (fsharp-mode) (insert ,src) (goto-char (point-min)) ;; Ensure we've syntax-highlighted the whole buffer. (if (fboundp 'font-lock-ensure) (font-lock-ensure) (with-no-warnings (font-lock-fontify-buffer))) ,@body)) (defun str-face (op) (goto-char (point-min)) (search-forward op) (left-char 2) (face-at-point)) (describe "When locking operators" (it "uses ui operator face for pipes" (with-highlighted "<<| |>> |> ||> |||> <| <|| <||| <|> <<|!" (should (equal (str-face " |> ") 'fsharp-ui-operator-face)) (should (equal (str-face " ||> ") 'fsharp-ui-operator-face)) (should (equal (str-face " |||> ") 'fsharp-ui-operator-face)) (should (equal (str-face " <| ") 'fsharp-ui-operator-face)) (should (equal (str-face " <|| ") 'fsharp-ui-operator-face)) (should (equal (str-face " <||| ") 'fsharp-ui-operator-face))))) (describe "When locking operators" (it "uses ui generic face for custom operators containing pipes" (with-highlighted "<<| |>> |> ||> |||> <| <|| <||| <|> <<|!" (should (equal (str-face "<<| ") 'fsharp-ui-generic-face)) (should (equal (str-face " |>> ") 'fsharp-ui-generic-face)) (should (equal (str-face " <|> ") 'fsharp-ui-generic-face)) (should (equal (str-face " <<|!") 'fsharp-ui-generic-face))))) ================================================ FILE: test/fsharp-mode-structure-tests.el ================================================ ;;; fsharp-mode-structure-tests.el --- -*- lexical-binding: t; -*- (require 'buttercup) (require 'fsharp-mode) (require 'fsharp-mode-structure) (defvar fsharp-struct-test-files-dir "test/StructureTest/") ;;-------------------------------- Regex Tests --------------------------------;; (ert-deftest fsharp-stringlit-re-test ()) ;;--------------------------- Structure Navigation ---------------------------;; ;; TODO[gastove|2019-10-31] This function turns out to be incredibly broken! It ;; wont move past the final line of _most_ multi-line expressions. Wonderful. ;; ;; This will get fixed in the next PR. ;; (ert-deftest fsharp-goto-beyond-final-line-test () ;; (let ((blocks-file (file-truename (concat fsharp-struct-test-files-dir "Blocks.fs")))) ;; (using-file blocks-file ;; ;; A single-line expression ;; (goto-char 1) ;; (fsharp-goto-beyond-final-line) ;; (should (eq (point) 19)) ;; ;; A multi-line expression using a pipe. We should wind up in the same ;; ;; place whether we start at the beginning or the end of the expression. ;; (goto-char 20) ;; (fsharp-goto-beyond-final-line) ;; (should (eq (point) 88)) ;; (goto-char 46) ;; (fsharp-goto-beyond-final-line) ;; (should (eq (point) 88)) ;; ;; A multi-line discriminated union. ;; (goto-char 89) ;; (fsharp-goto-beyond-final-line) ;; (should (eq (point) 146)) ;; (goto-char 122) ;; (fsharp-goto-beyond-final-line) ;; (should (eq (point) 146)) ;; ;; A function using an if/else block ;; (goto-char 147) ;; (fsharp-goto-beyond-final-line) ;; (should (eq (point) 218)) ;; (goto-char 171) ;; (fsharp-goto-beyond-final-line) ;; (should (eq (point) 218)) ;; ))) ;;-------------------------------- Predicates --------------------------------;; (describe "The `fsharp-backslash-continuation-line-p' predicate" (it "returns true when we expect it to" (let ((file (file-truename (concat fsharp-struct-test-files-dir "ContinuationLines.fs")))) (with-current-buffer (find-file-noselect file) (beginning-of-buffer) (should (eq (fsharp--hanging-operator-continuation-line-p) nil)) (forward-line 1) (should (eq (fsharp--hanging-operator-continuation-line-p) nil)) (forward-line 5) (should (eq (fsharp--hanging-operator-continuation-line-p) t)))))) (describe "The `fsharp-in-literal-p'" (it "return non-nil in both strings and comments?" (let ((literals-file (file-truename (concat fsharp-struct-test-files-dir "Literals.fs")))) (with-current-buffer (find-file-noselect literals-file) ;; Comments (goto-char 3) (should (eq (fsharp-in-literal-p) 'comment)) (goto-char 642) (should (eq (fsharp-in-literal-p) 'comment)) (goto-char 968) (should (eq (fsharp-in-literal-p) 'comment)) (goto-char 1481) (should (eq (fsharp-in-literal-p) 'comment)) (goto-char 2124) (should (eq (fsharp-in-literal-p) 'comment)) ;; String literals (goto-char 2717) (should (eq (fsharp-in-literal-p) 'string)) ;; This string contains an inner, backslash-escaped string. ;; First, with point outside the backslash-escaped string: (goto-char 2759) (should (eq (fsharp-in-literal-p) 'string)) ;; ...and now with point inside it (goto-char 2774) (should (eq (fsharp-in-literal-p) 'string)) ;; Inside triple-quoted strings (goto-char 2835) (should (eq (fsharp-in-literal-p) 'string)) (goto-char 2900) (should (eq (fsharp-in-literal-p) 'string)))))) ;; NOTE[gastove|2019-10-31] I am entirely convinced this doesn't work precisely ;; as it should, because it depends on `fsharp-goto-beyond-final-line', which I ;; am positive is buggy. ;; ;; Udate: yep! It's buggy! Will uncomment and fix in the next PR. ;; (ert-deftest fsharp-statement-opens-block-p-test () ;; "Does `fsharp-statement-opens-block-p' correctly detect block-opening statements?" ;; (let ((blocks-file (file-truename (concat fsharp-struct-test-files-dir "Blocks.fs")))) ;; (using-file blocks-file ;; (goto-char 1) ;; (should-not (fsharp-statement-opens-block-p)) ;; (goto-char 20) ;; (should (fsharp-statement-opens-block-p)) ;; (goto-char 89) ;; (should (fsharp-statement-opens-block-p))))) ;;--------------------- Nesting and Indentation Functions ---------------------;; (describe "The `fsharp-nesting-level' function" (it "returns nil when we expect it to" (with-temp-buffer (insert "let x = 5") (end-of-buffer) (should (eq (fsharp-nesting-level) nil))))) (describe "The `fsharp-nesting-level' function" :var ((file (file-truename (concat fsharp-struct-test-files-dir "Nesting.fs")))) (it "correctly return the point position of the opening pair closest to point" ;; The character positions use here reference characters noted in comments in Nesting.fs ;; Test a normal list (with-current-buffer (find-file-noselect file) (goto-char 645) (should (eq (fsharp-nesting-level) 640))) ;; Get the opening bracket of an inner list from a single-line nested list (with-current-buffer (find-file-noselect file) (goto-char 717) (should (eq (fsharp-nesting-level) 706))) ;; Opening bracket for a multi-line non-nested list (with-current-buffer (find-file-noselect file) (goto-char 795) (should (eq (fsharp-nesting-level) 777))) ;; Inner most opening bracket for a multi-line multi-nested list (with-current-buffer (find-file-noselect file) (goto-char 960) (should (eq (fsharp-nesting-level) 955))) ;; Middle opening bracket for same list as previous (with-current-buffer (find-file-noselect file) (goto-char 954) (should (eq (fsharp-nesting-level) 953))) (with-current-buffer (find-file-noselect file) (goto-char 974) (should (eq (fsharp-nesting-level) 953))) ;; Outermost opening bracket for same list (with-current-buffer (find-file-noselect file) (goto-char 977) (should (eq (fsharp-nesting-level) 947))) ;; Basic Async form, should return the opening { (with-current-buffer (find-file-noselect file) (goto-char 1088) (should (eq (fsharp-nesting-level) 1060))) ;; Same async form, inner async call (with-current-buffer (find-file-noselect file) (goto-char 1129) (should (eq (fsharp-nesting-level) 1121))) ;; Lambda, wrapped in parens, should return the opening ( (with-current-buffer (find-file-noselect file) (goto-char 1238) (should (eq (fsharp-nesting-level) 1208))))) (describe "The `fsharp--compute-indentaiton-open-bracket'" :var ((file (file-truename (concat fsharp-struct-test-files-dir "BracketIndent.fs")))) (it "returns the correct indentation in a variety of cases" (with-current-buffer (find-file-noselect file) ;; Opening bracket on same line as let, elements on same line; test element (goto-char 44) (let* ((nesting-level (fsharp-nesting-level)) (indent-at-point (fsharp--compute-indentation-open-bracket nesting-level))) ;; The value we expect (should (eq indent-at-point 18)) ;; Both entrypoints should have the same answer (should (eq indent-at-point (fsharp-compute-indentation t)))) ;; Opening bracket on same line as let, elements on same line; test newline (goto-char 81) (let* ((nesting-level (fsharp-nesting-level)) (indent-at-point (fsharp--compute-indentation-open-bracket nesting-level))) ;; The value we expect (should (eq indent-at-point 18)) ;; Both entrypoints should have the same answer (should (eq indent-at-point (fsharp-compute-indentation t)))) ;; Opening bracket on same line as let, elements on new line; test element (goto-char 148) (let* ((nesting-level (fsharp-nesting-level)) (indent-at-point (fsharp--compute-indentation-open-bracket nesting-level))) (should (eq indent-at-point 4)) (should (eq indent-at-point (fsharp-compute-indentation t)))) ;; Opening bracket on same line as let, elements on new line; test newline (goto-char 155) (let* ((nesting-level (fsharp-nesting-level)) (indent-at-point (fsharp--compute-indentation-open-bracket nesting-level))) (should (eq indent-at-point 4)) (should (eq indent-at-point (fsharp-compute-indentation t)))) ;; Opening bracket on own line; test element (goto-char 231) (let* ((nesting-level (fsharp-nesting-level)) (indent-at-point (fsharp--compute-indentation-open-bracket nesting-level))) (should (eq indent-at-point 6)) (should (eq indent-at-point (fsharp-compute-indentation t)))) ;; Opening bracket on own line; test newline (goto-char 236) (let* ((nesting-level (fsharp-nesting-level)) (indent-at-point (fsharp--compute-indentation-open-bracket nesting-level))) (should (eq indent-at-point 6)) (should (eq indent-at-point (fsharp-compute-indentation t))))))) (describe "The `fsharp--compute-indentation-continuation-line' function" :var ((continuation-line "let x = 5 +")) (it "indents correctly" (with-temp-buffer (fsharp-mode) (insert continuation-line) (fsharp-newline-and-indent) (should (eq (fsharp--compute-indentation-continuation-line) 8)) (should (eq (fsharp--compute-indentation-continuation-line) (fsharp-compute-indentation t)))))) (describe "The `fsharp-compute-indentation-relative-to-previous' function'" :var ((file (concat fsharp-struct-test-files-dir "Relative.fs"))) (it "indents correctly releative to previous line" ;; Discriminated unions (with-current-buffer (find-file-noselect file) (goto-char 57) (should (eq (fsharp--compute-indentation-relative-to-previous t) 4)) (should (eq (fsharp--compute-indentation-relative-to-previous t) (fsharp-compute-indentation t))) ;; If/Else blocks ;; if an if then are on the same line, the next line is indented (goto-char 96) (should (eq (fsharp--compute-indentation-relative-to-previous t) 4)) (should (eq (fsharp--compute-indentation-relative-to-previous t) (fsharp-compute-indentation t))) ;; An else is not indented further; *however*, the indentation relative to ;; previous will be 4, but `fsharp-compute-indentation' will return 0 ;; because the previous line is not a continuation line. ;; ;; However! This test case doesn't currently work. Indentation code ;; produces indent of 0, but the compute indentation functions proudce an ;; indent of 4, which is wrong. ;; ;; (goto-char 124) ;; (should (eq (fsharp--compute-indentation-relative-to-previous t) 4)) ;; (should-not (eq (fsharp--compute-indentation-relative-to-previous t) ;; (fsharp-compute-indentation t))) ;; when a then is on its own line, the next line is indented (goto-char 154) (should (eq (fsharp--compute-indentation-relative-to-previous t) 4)) (should (eq (fsharp--compute-indentation-relative-to-previous t) (fsharp-compute-indentation t))) ;; likewise an else (goto-char 180) (should (eq (fsharp--compute-indentation-relative-to-previous t) 4)) (should (eq (fsharp--compute-indentation-relative-to-previous t) (fsharp-compute-indentation t)))))) (describe "The `fsharp-compute-indentation'" :var ((file (concat fsharp-struct-test-files-dir "BracketIndent.fs"))) (it "indents on the first line after opening bracket" (with-current-buffer (find-file-noselect file) (goto-char (point-min)) (search-forward-regexp "let formatTwo = \\[\n") (should (eq (fsharp-compute-indentation t) fsharp-indent-offset))))) ================================================ FILE: test/fsi-tests.el ================================================ ;;; fsi-tests.el --- Tests for F# interactive -*- lexical-binding: t; -*- ;; Copyright (C) 2022-2023 Jürgen Hötzel ;; Author: Jürgen Hötzel ;; Keywords: processes ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . ;;; Commentary: ;; ;;; Code: (load "project") ;Emacs 27 workaround: https://github.com/joaotavora/eglot/issues/549 (require 'buttercup) (require 'fsharp-mode) (defun fsi-tests-wait-for-regex (timeout regexp) (let ((start-time (float-time))) (while (and (< (- (float-time) start-time) timeout) (not (progn (goto-char (point-min)) (search-forward-regexp regexp nil t)))) (if (accept-process-output (get-buffer-process (current-buffer)) 0.2) (message "[FSI Interactive] received output...") (message "[FSI Interactive] waiting for output..."))))) (describe "F# interactive" :before-all (run-fsharp inferior-fsharp-program) :before-each (with-current-buffer (get-buffer inferior-fsharp-buffer-name) (comint-clear-buffer)) (it "can eval expressions" (with-current-buffer (find-file-noselect "test/expression.fsx") (fsharp-eval-region (point-min) (point-max)) (with-current-buffer (get-buffer inferior-fsharp-buffer-name) (fsi-tests-wait-for-regex 25 "it: int = 2$") (let ((result (match-string-no-properties 0))) (expect result :to-equal "it: int = 2"))))) (it "can load nuget references" (let ((timeout 50) (fsx-file "test/nuget.fsx")) (with-current-buffer (find-file-noselect fsx-file) (fsharp-load-buffer-file) (with-current-buffer (get-buffer inferior-fsharp-buffer-name) (fsi-tests-wait-for-regex 25 "xxx:\\(.*\\):xxx") (let ((json-str (match-string-no-properties 1))) (unless json-str (warn "FSI output doesn't contain marker: %s" (buffer-substring-no-properties (point-min) (point-max)))) (expect json-str :to-equal "{\"X\":2,\"Y\":\"Hello\"}"))))))) (provide 'fsi-tests) ;;; fsi-tests.el ends here ================================================ FILE: test/integration-tests.el ================================================ ;;; integration-tests.el --- -*- lexical-binding: t; -*- ;; Copyright (C) 2019-2023 Jürgen Hötzel ;; Author: Jürgen Hötzel ;; Keywords: abbrev, abbrev ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . ;;; Commentary: ;; This file is part of fsharp-mode ;;; Code: (load "project") ;Emacs 27 workaround: https://github.com/joaotavora/eglot/issues/549 (require 'buttercup) (require 'eglot-fsharp) (load "test/eglot-fsharp-integration-util.el") ;; FIXME/HELP WANTED: fsautocomplete process don't seem to terminate on windows (Access denied when trying to install ;; different version) (unless (eq system-type 'windows-nt) (describe "F# LSP Installation" :before-all (setq latest-version (eglot-fsharp--latest-version)) (it "succeeds using version 0.77.2" (eglot-fsharp--maybe-install "0.77.2") (expect (eglot-fsharp--installed-version) :to-equal "0.77.2")) (it (format "succeeds using latest version: %s)" latest-version) (eglot-fsharp--maybe-install) (expect (eglot-fsharp--installed-version) :to-equal latest-version)))) (describe "F# LSP Client" :before-all (progn (setq latest-version (eglot-fsharp--latest-version)) (with-temp-buffer (unless (zerop (process-file "dotnet" nil (current-buffer) nil "restore" "test/Test1")) (signal 'file-error (buffer-string)))) (eglot-fsharp--maybe-install) (with-current-buffer (eglot-fsharp--find-file-noselect "test/Test1/FileTwo.fs") (eglot-fsharp--tests-connect 10) (eglot-fsharp--sniff-method "fsharp/notifyWorkspace"))) (it "Can be invoked" ;; FIXME: Should use dotnet tool run (expect (process-file (eglot-fsharp--path-to-server) nil nil nil "--version") :to-equal 0)) (it "is enabled on F# Files" (with-current-buffer (eglot-fsharp--find-file-noselect "test/Test1/FileTwo.fs") (expect (type-of (eglot--current-server-or-lose)) :to-be 'eglot-fsautocomplete))) (it "shows flymake errors" (with-current-buffer (eglot-fsharp--find-file-noselect "test/Test1/Error.fs") (flymake-mode t) (flymake-start) (eglot-fsharp--sniff-diagnostics "test/Test1/Error.fs") (goto-char (point-min)) (search-forward "nonexisting") (insert "x") (eglot--signal-textDocument/didChange) (flymake-goto-next-error 1 '() t) (expect (face-at-point) :to-be 'flymake-error ))) (it "provides completion" (with-current-buffer (eglot-fsharp--find-file-noselect "test/Test1/FileTwo.fs") (expect (plist-get (eglot--capabilities (eglot--current-server-or-lose)) :completionProvider) :not :to-be nil))) (it "completes function in other modules" (with-current-buffer (eglot-fsharp--find-file-noselect "test/Test1/Program.fs") (search-forward "X.func") (delete-char -3) (completion-at-point) (expect (looking-back "X\\.func") :to-be t))) (it "finds definition in pervasives" (with-current-buffer (eglot-fsharp--find-file-noselect "test/Test1/Program.fs") (search-forward "printfn") (expect (current-word) :to-equal "printfn") ;sanity check (call-interactively #'xref-find-definitions) (expect (file-name-nondirectory (buffer-file-name)) :to-equal "fslib-extra-pervasives.fs"))) (it "finds definitions in other files of Project" (with-current-buffer (eglot-fsharp--find-file-noselect "test/Test1/Program.fs") (goto-char 150) (expect (current-word) :to-equal "NewObjectType") ;sanity check (call-interactively #'xref-find-definitions) (expect (file-name-nondirectory (buffer-file-name)) :to-equal "FileTwo.fs")))) (provide 'integration-tests) ;;; integration-tests.el ends here ================================================ FILE: test/nuget.fsx ================================================ #r "nuget: Newtonsoft.Json";; open Newtonsoft.Json;; let o = {| X = 2; Y = "Hello" |};; printfn "xxx:%s:xxx" (JsonConvert.SerializeObject o);;