[ { "path": ".dir-locals.el", "content": ";;; Directory Local Variables\n;;; For more information see (info \"(emacs) Directory Variables\")\n\n((emacs-lisp-mode . ((indent-tabs-mode . nil)\n\t\t (fill-column . 120))))\n" }, { "path": ".github/pull_request_template.md", "content": "## Description\n\n\n\n## How to test\n\n\n\n## Related issues\n\n\n" }, { "path": ".github/workflows/test.yml", "content": "name: \"CI\"\non:\n pull_request:\n push:\n branches:\n - master\njobs:\n gnu-build:\n strategy:\n fail-fast: false\n matrix:\n os: [ubuntu-latest, macos-latest]\n dotnet: [9.0.x]\n emacs_version:\n - 28.2\n - 29.4\n - 30.2\n - snapshot\n runs-on: ${{ matrix.os }}\n steps:\n - uses: actions/checkout@v4\n - uses: actions/setup-dotnet@v4\n with:\n dotnet-version: ${{ matrix.dotnet }}\n - uses: purcell/setup-emacs@master\n with:\n version: ${{ matrix.emacs_version }}\n - name: Install Eldev\n run: curl -fsSL https://raw.github.com/doublep/eldev/master/webinstall/github-eldev | sh\n - name: Show dotnet sdks\n run: dotnet --list-sdks\n - name: Show dotnet version\n run: dotnet --info\n - name: Eldev archives\n run: |\n echo \"Archives:\"\n eldev archives\n - name: Eldev dependencies\n run: |\n echo \"Dependencies:\"\n eldev -v dependencies\n - name: Test\n run: |\n echo \"Testing:\"\n eldev -dtT test\n \n windows-build:\n runs-on: windows-latest\n strategy:\n fail-fast: false\n steps:\n - uses: actions/checkout@v4\n - uses: actions/setup-dotnet@v4\n with:\n dotnet-version: 9.0.x\n - name: Show dotnet sdks\n run: dotnet --list-sdks\n - name: Show dotnet version\n run: dotnet --info\n - name: Set up Emacs on Windows\n uses: jcs090218/setup-emacs-windows@master\n with:\n version: 29.4\n - name: Install Eldev\n run: curl.exe -fsSL https://raw.github.com/doublep/eldev/master/webinstall/eldev.bat | cmd /Q\n - name: Eldev archives\n run: |\n echo \"Archives:\"\n ~/.local/bin/eldev.bat archives\n - name: Eldev dependencies\n run: |\n echo \"Dependencies:\"\n ~/.local/bin/eldev.bat dependencies\n - name: Test\n run: |\n echo \"Testing:\"\n ~/.local/bin/eldev.bat -p -dtT test\n" }, { "path": ".gitignore", "content": "*.elc\nbin\ntmp\n*~\n\n# Useful for doing releases\nemacs-fsharp-mode-bin/\n\n# Dependency archive\nfsautocomplete-*.zip\n\n# Development\nobj/\n.ionide/\n" }, { "path": "CHANGELOG.md", "content": "## 1.10 (2019.12-01)\n\nFeatures:\n - #210: Remove old FsAutoComplete support (use LSP)\n\t- provide eglot (Emacs LSP client) integration and add eglot\n integration tests (using Emacs buttercup)\n - Use Cask instead to automate the package development cycle;\n development, dependencies, testing, building, packaging\n - Make project.el aware of F# projects\n - Use Emacs org-mode for README\nBugfixes:\n - #68: Indentation Cleanup / SMIE mode not being applied properly\n (Gastove)\n\n## 1.9.14 (2019-06-09)\n\nFeatures:\n - #207: Update to FsAutoComplete 0.38.1\n - #206: Set default build command to msbuild if found\nBugfixes:\n - #198: Use buffer-local version of company-quickhelp-mode\n\n## 1.9.13 (2018)\n\nFeatures:\n - #193: Update to FSAC 0.36\n\t - Fixes #183: Load .Net Core projects that reference other projects\n\t - Fixes #182: .fs files not parsed\nBugfixes:\n - #190: Fix attribute locking, improve imenu support\n - #189: Fix bug in font locking for active patterns\n - #187: Fix Infinite loop when file begins with a comment preceded\n by whitespace\n - #180: Use scoop instead of Chocolatey package for Appveyor testing\n - #179: Use portable (Windows support) Makefile\n - #176: Add F# Tools 10.1 SDK directory to search dirs\n - #175: Paths with characters outside ASCII gives error FS2302 (Windows)\n - #171: Fix for phrase detection for if/then/else constructs\n\n## 1.9.12 (2018-05-18)\n\nFeatures:\n - #170: Flycheck verify (Improved fsautocomplete diagnostics)\n\nBugfixes:\n - #167: Fix error when visiting a new F# script file and\n fsautocomplete is not started\n - #168: Add Flycheck predicate function to prevent error when\n fsautocomplete is not running\n - #162: Stop matching [ as part of normal residue\n - #157: Don't change global value of `comment-indent-function'\n - #153: Add access control keywords to declaration regexes\n\n## 1.9.11 (2017-10-21)\n\nFeatures:\n - #151: Correctly find MSBuild from VS2017\n\nBugfixes:\n - #152: Handle failure to find build commands gracefully\n\n## 1.9.10 (2017-09-18)\n\nBugfixes:\n - #146: Understand FSAC 0.34 error msgs\n\n## 1.9.9 (2017-09-15)\n\nFeatures\n - #143: Update to FsAutoComplete 0.34.0\n\nBugfixes:\n - #139: Disable flycheck and fsharp-doc-mode when fsharp-ac-intellisense-enabled is nil\n\n## 1.9.8 (2017-06-17)\n\nFeatures:\n - #134: Improved logging\n - #137: fsharp-shift-region-[left,right]: change bindings to 'C-c <' and 'C-c >'\n\nBugfixes:\n - #136: Use correct F# interactive prompt regex\n\n## 1.9.7 (2017-06-06)\n\nBugfixes:\n - #131: Don't panic on malformed JSON (debug messages)\n - #133: Update faceup to capture font-locking <|\n\n## 1.9.6 (2017-04-16)\n\nFeatures:\n - #127: Update to FsAutoComplete 0.32.0 (.NET Core project support)\n\nBugfixes:\n - #125: Small fixes to try to prevent fsharp-mode to freeze all emacs \n - #122: Make fsharp-doc-mode hook buffer-local\n\n## 1.9.5 (2017-01-21)\n\nBugfixes:\n - #117: Fix `type` locking\n - #118: Don't change company-idle-delay\n - #120: Fix FSAC hanging issue\n\n## 1.9.4 (2016-11-30)\n\nFeatures\n - #116: Improve Active Pattern font locking, eval-when-compile the main font-lock-keywords form\n - #114: Clean up font-locking code\n\n## 1.9.3 (2016-10-31)\nFeatures\n - #111: Update to FsAutoComplete 0.32.0\n - #109: Define inferior-fsharp-mode as variant of comint mode\n\nBugfixes:\n - #110: Dont change default indent region function\n - #105: Don't send trailing newline to fsautocomplete\n - #104: Dont change `company-minimum-prefix-length'\n\n## 1.9.2 (2016-09-30)\nFeatures\n - #98: Enable imenu support\n\n## 1.9.1 (2016-07-19)\n\nFeatures:\n - Update to FsAutoComplete 0.29.0.\n\n## 1.9.0 (2016-07-09)\n\nFeatures:\n - #71: fontify the doc string (@nosami).\n - #77: Use new typesig command for fsharp-doc mode (@rneatherway).\n - #88: Use flycheck for error reporting (@juergenhoetzel).\n\nBugfixes:\n - #75: Do not change current buffer when starting FSI (@rneatherway).\n - #76: Record type highlighting (@rneatherway).\n - #79: Overlays should not grow when typing (@rneatherway).\n - #82: Inferior fsi: #silentcd to local directory in Tramp (@juergenhoetzel).\n - #83: Fix completion of type annotated symbols (@juergenhoetzel).\n - #85: Don't modify company-transformers (@nosami).\n - #86: Don't clobber company-backends (@nosami).\n\n## 1.8.1 (2016-04-14)\n\nFeatures:\n - #66: Tramp support (@juergenhoetzel).\n - #69: Prefer exact case sort in completion list (@nosami).\n\n## 1.8.0 (2016-04-05)\n\nFeatures:\n - Update to FsAutoComplete 0.28.0 to support #65.\n - #65: Faster completions (thanks to @nosami).\n - #56: Use FsAutoComplete \"startswith\" filter (thanks to @juergenhoetzel).\n\nBugfixes:\n - #67: Fix use of popup (thanks to @drvink)\n - #60: Unbreak company support on non-graphic displays (thanks to @drvink)\n - #58: Handle buffers not visiting a file (thanks to @juergenhoetzel).\n\n## 1.7.4 (2016-02-05)\n\nFeatures:\n - #49: Use company for completions (thanks to @nosami).\n\nBugfixes:\n - Update to FsAutoComplete 0.27.2, fixes project cracking for files\n with spaces in the path.\n\n## 1.7.3 (2016-01-26)\n\nBugfixes:\n - Update to FsAutoComplete 0.27.1, fixes Windows VS2015-only support.\n\n## 1.7.2 (2016-01-08)\n\nBugfixes:\n - #50: Inhibit electric-indent for fsharp-mode buffers (thanks to @joranvar).\n\n## 1.7.1 (2015-11-24)\n\nFeatures:\n - #45: Update FSAC to 0.27, enable project cracking logs.\n\n## 1.7.0 (2015-11-24)\n\nFeatures:\n - #34: Switch to SMIE-based indentation engine (thanks to m00nlight).\n - #31: Add highlighting of other usages of symbol at point.\n\n## 1.6.3 (2015-10-24)\n\nBugfixes:\n - Update to FsAutoComplete 0.26.1, which fixes Windows support.\n\n## 1.6.2 (2015-10-20)\n\nBugfixes:\n - Update to FsAutoComplete 0.26.0.\n - #30: Allow use of symbols containing '%'\n - #28: Fix FSI usage in buffers whose name differs from filename\n - #27: Fix test of fsharp-ac-debug\n\n## 1.6.1 (2015-09-02)\n\nBugfixes:\n - Update to FsAutoComplete 0.23.1. Fixed MSBuild v14 on non-English\n systems.\n\n## 1.6.0 (2015-09-01)\n\nFeatures:\n - Update to FSharp.AutoComplete 0.23.0. Contains many improvements,\n which can be found in the changelog at\n https://github.com/fsharp/FsAutoComplete/releases\n - #20: Add C-x C-e as default keybinding for eval.\n - #22: Allow .fsx files to be compiled as well.\n\nBugfixes:\n - #16: Remove BOM from process output.\n\n## 1.5.4 (2015-06-04)\n\nFeatures:\n - #4: Update to FSharp.AutoComplete 0.18.0. All unsaved buffer\n contents (not just the current buffer) will now be used for type\n checking.\n\nBugfixes:\n - #9: Correct quoting of path to fsi.exe on Windows.\n\n## 1.5.3 (2015-05-26)\n\nNote that in since 1.5.2 fsharp-mode has been migrated from\nhttps://github.com/fsharp/fsharpbinding to a\n[separate repository](https://github.com/fsharp/emacs-fsharp-mode).\nThe issue number `#2` below, and all future issue numbers, refer to the\nnew repository.\n\nFeatures:\n - #993: Push the mark before going to definition (using etags)\n\nBugfixes:\n - #1005: Fix issue with compile-command quoting\n - #2: Add `do!` as a keyword.\n\n## 1.5.2 (2015-03-20)\n\nBugfixes:\n - #973: Force comint-process-echoes to nil to avoid hangs\n\n## 1.5.1 (2015-01-14)\n\nBugfixes:\n - #923: Autocompletion not working on Emacs 24.4+ on Windows\n\n## 1.5.0 (2014-11-25)\n\nIncorporate FSharp.AutoComplete version 0.13.3, which has corrected help text for the parse command and uses FCS 0.0.81.\n\nFeatures:\n - #235: Support multiple projects simultaneously\n\nBugfixes:\n - #824: Emacs should give a better error message if fsautocomplete not found\n - #808: C-c C-p gives an error if no project file above current file's directory\n - #790: Can't make fsac requests in indirect buffers\n - #754: Compiler warnings when installing fsharp-mode from MELPA\n\n## 1.4.2 (2014-10-30)\n\nIncorporate FSharp.AutoComplete version 0.13.2, which returns more information if the project parsing fails.\n\nFeatures:\n - #811: Return exception message on project parsing fail\n\n## 1.4.1 (2014-10-30)\n\nIncorporate FSharp.AutoComplete version 0.13.1, which contains a fix for goto definition.\n\nBugfixes:\n - #787: Correct off-by-one error in fsac goto definition\n\n## 1.4.0 (2014-10-26)\n\nThe main feature of this release is that the project parsing logic has\nbeen moved to FSharp.Compiler.Service as part of fixing #728.\n\nFeatures:\n - #319: Better error feedback when no completion data available\n - #720: Rationalise emacs testing, also fixed #453\n\nBugfixes:\n - #765: Do not offer completions in irrelevant locations (strings/comments)\n - #721: Tests for Emacs syntax highlighting, and resultant fixes\n - #248: Run executable file now uses output from FSharp.AutoComplete\n - #728: Fix project support on Windows\n\n## 1.3.0 (2014-08-28)\n\nChanges by @rneatherway unless otherwise noted.\n\nMajor changes in this release are performance improvements thanks to @juergenhoetzel (avoiding parsing the current buffer unless necessary), and\nfixes for syntax highlighting.\n\n\nFeatures:\n - #481: Only parse the current buffer if it is was modified (@juergenhoetzel)\n\nBugfixes:\n - #619: Disable FSI syntax highlighting\n - #670: Prevent double dots appearing during completion\n - #485: Fetch SSL certs before building exe in emacs dir\n - #496: Corrections to emacs syntax highlighting\n - #597: Highlight preprocessor and async\n - #605: Add FSI directives to syntax highlighting of emacs\n - #571: Correct range-check for emacs support\n - #572: Ensure fsi prompt is readonly\n - #452: Fetch SSL certs before building exe in emacs dir\n" }, { "path": "Eldev", "content": "; -*- mode: emacs-lisp; lexical-binding: t -*-\n\n(setq package-lint-main-file \"eglot-fsharp.el\")\n(setq eldev-project-main-file \"eglot-fsharp.el\")\n\n(eldev-use-package-archive 'melpa-unstable)\n(eldev-use-package-archive 'gnu)\n(eldev-use-plugin 'autoloads)\n(setq package-archive-priorities\n '((\"melpa-unstable\" . 400)\n\t(\"gnu\" . 300)))\n\n\n\n" }, { "path": "ISSUE_TEMPLATE.md", "content": "\n### Description\n\nPlease provide a succinct description of your issue.\n\n### Repro steps\n\nPlease provide the steps required to reproduce the problem\n\n1. Step A\n\n2. Step B\n\n### Expected behavior\n\nPlease provide a description of the behaviour you expect.\n\n### Actual behavior\n\nPlease provide a description of the actual behaviour you observe. \n\n### Known workarounds\n\nPlease provide a description of any known workarounds.\n\n### Related information \n\n* Operating system\n* Branch\n* Emacs version\n* .NET Runtime, CoreCLR or Mono Version\n* Performance information, links to performance testing scripts\n" }, { "path": "LICENSE", "content": "\n Apache License\n Version 2.0, January 2004\n http://www.apache.org/licenses/\n\n TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION\n\n 1. Definitions.\n\n \"License\" shall mean the terms and conditions for use, reproduction,\n and distribution as defined by Sections 1 through 9 of this document.\n\n \"Licensor\" shall mean the copyright owner or entity authorized by\n the copyright owner that is granting the License.\n\n \"Legal Entity\" shall mean the union of the acting entity and all\n other entities that control, are controlled by, or are under common\n control with that entity. For the purposes of this definition,\n \"control\" means (i) the power, direct or indirect, to cause the\n direction or management of such entity, whether by contract or\n otherwise, or (ii) ownership of fifty percent (50%) or more of the\n outstanding shares, or (iii) beneficial ownership of such entity.\n\n \"You\" (or \"Your\") shall mean an individual or Legal Entity\n exercising permissions granted by this License.\n\n \"Source\" form shall mean the preferred form for making modifications,\n including but not limited to software source code, documentation\n source, and configuration files.\n\n \"Object\" form shall mean any form resulting from mechanical\n transformation or translation of a Source form, including but\n not limited to compiled object code, generated documentation,\n and conversions to other media types.\n\n \"Work\" shall mean the work of authorship, whether in Source or\n Object form, made available under the License, as indicated by a\n copyright notice that is included in or attached to the work\n (an example is provided in the Appendix below).\n\n \"Derivative Works\" shall mean any work, whether in Source or Object\n form, that is based on (or derived from) the Work and for which the\n editorial revisions, annotations, elaborations, or other modifications\n represent, as a whole, an original work of authorship. For the purposes\n of this License, Derivative Works shall not include works that remain\n separable from, or merely link (or bind by name) to the interfaces of,\n the Work and Derivative Works thereof.\n\n \"Contribution\" shall mean any work of authorship, including\n the original version of the Work and any modifications or additions\n to that Work or Derivative Works thereof, that is intentionally\n submitted to Licensor for inclusion in the Work by the copyright owner\n or by an individual or Legal Entity authorized to submit on behalf of\n the copyright owner. For the purposes of this definition, \"submitted\"\n means any form of electronic, verbal, or written communication sent\n to the Licensor or its representatives, including but not limited to\n communication on electronic mailing lists, source code control systems,\n and issue tracking systems that are managed by, or on behalf of, the\n Licensor for the purpose of discussing and improving the Work, but\n excluding communication that is conspicuously marked or otherwise\n designated in writing by the copyright owner as \"Not a Contribution.\"\n\n \"Contributor\" shall mean Licensor and any individual or Legal Entity\n on behalf of whom a Contribution has been received by Licensor and\n subsequently incorporated within the Work.\n\n 2. Grant of Copyright License. Subject to the terms and conditions of\n this License, each Contributor hereby grants to You a perpetual,\n worldwide, non-exclusive, no-charge, royalty-free, irrevocable\n copyright license to reproduce, prepare Derivative Works of,\n publicly display, publicly perform, sublicense, and distribute the\n Work and such Derivative Works in Source or Object form.\n\n 3. Grant of Patent License. Subject to the terms and conditions of\n this License, each Contributor hereby grants to You a perpetual,\n worldwide, non-exclusive, no-charge, royalty-free, irrevocable\n (except as stated in this section) patent license to make, have made,\n use, offer to sell, sell, import, and otherwise transfer the Work,\n where such license applies only to those patent claims licensable\n by such Contributor that are necessarily infringed by their\n Contribution(s) alone or by combination of their Contribution(s)\n with the Work to which such Contribution(s) was submitted. If You\n institute patent litigation against any entity (including a\n cross-claim or counterclaim in a lawsuit) alleging that the Work\n or a Contribution incorporated within the Work constitutes direct\n or contributory patent infringement, then any patent licenses\n granted to You under this License for that Work shall terminate\n as of the date such litigation is filed.\n\n 4. Redistribution. You may reproduce and distribute copies of the\n Work or Derivative Works thereof in any medium, with or without\n modifications, and in Source or Object form, provided that You\n meet the following conditions:\n\n (a) You must give any other recipients of the Work or\n Derivative Works a copy of this License; and\n\n (b) You must cause any modified files to carry prominent notices\n stating that You changed the files; and\n\n (c) You must retain, in the Source form of any Derivative Works\n that You distribute, all copyright, patent, trademark, and\n attribution notices from the Source form of the Work,\n excluding those notices that do not pertain to any part of\n the Derivative Works; and\n\n (d) If the Work includes a \"NOTICE\" text file as part of its\n distribution, then any Derivative Works that You distribute must\n include a readable copy of the attribution notices contained\n within such NOTICE file, excluding those notices that do not\n pertain to any part of the Derivative Works, in at least one\n of the following places: within a NOTICE text file distributed\n as part of the Derivative Works; within the Source form or\n documentation, if provided along with the Derivative Works; or,\n within a display generated by the Derivative Works, if and\n wherever such third-party notices normally appear. The contents\n of the NOTICE file are for informational purposes only and\n do not modify the License. You may add Your own attribution\n notices within Derivative Works that You distribute, alongside\n or as an addendum to the NOTICE text from the Work, provided\n that such additional attribution notices cannot be construed\n as modifying the License.\n\n You may add Your own copyright statement to Your modifications and\n may provide additional or different license terms and conditions\n for use, reproduction, or distribution of Your modifications, or\n for any such Derivative Works as a whole, provided Your use,\n reproduction, and distribution of the Work otherwise complies with\n the conditions stated in this License.\n\n 5. Submission of Contributions. Unless You explicitly state otherwise,\n any Contribution intentionally submitted for inclusion in the Work\n by You to the Licensor shall be under the terms and conditions of\n this License, without any additional terms or conditions.\n Notwithstanding the above, nothing herein shall supersede or modify\n the terms of any separate license agreement you may have executed\n with Licensor regarding such Contributions.\n\n 6. Trademarks. This License does not grant permission to use the trade\n names, trademarks, service marks, or product names of the Licensor,\n except as required for reasonable and customary use in describing the\n origin of the Work and reproducing the content of the NOTICE file.\n\n 7. Disclaimer of Warranty. Unless required by applicable law or\n agreed to in writing, Licensor provides the Work (and each\n Contributor provides its Contributions) on an \"AS IS\" BASIS,\n WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or\n implied, including, without limitation, any warranties or conditions\n of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A\n PARTICULAR PURPOSE. You are solely responsible for determining the\n appropriateness of using or redistributing the Work and assume any\n risks associated with Your exercise of permissions under this License.\n\n 8. Limitation of Liability. In no event and under no legal theory,\n whether in tort (including negligence), contract, or otherwise,\n unless required by applicable law (such as deliberate and grossly\n negligent acts) or agreed to in writing, shall any Contributor be\n liable to You for damages, including any direct, indirect, special,\n incidental, or consequential damages of any character arising as a\n result of this License or out of the use or inability to use the\n Work (including but not limited to damages for loss of goodwill,\n work stoppage, computer failure or malfunction, or any and all\n other commercial damages or losses), even if such Contributor\n has been advised of the possibility of such damages.\n\n 9. Accepting Warranty or Additional Liability. While redistributing\n the Work or Derivative Works thereof, You may choose to offer,\n and charge a fee for, acceptance of support, warranty, indemnity,\n or other liability obligations and/or rights consistent with this\n License. However, in accepting such obligations, You may act only\n on Your own behalf and on Your sole responsibility, not on behalf\n of any other Contributor, and only if You agree to indemnify,\n defend, and hold each Contributor harmless for any liability\n incurred by, or claims asserted against, such Contributor by reason\n of your accepting any such warranty or additional liability.\n\n END OF TERMS AND CONDITIONS\n\n APPENDIX: How to apply the Apache License to your work.\n\n To apply the Apache License to your work, attach the following\n boilerplate notice, with the fields enclosed by brackets \"[]\"\n replaced with your own identifying information. (Don't include\n the brackets!) The text should be enclosed in the appropriate\n comment syntax for the file format. We also recommend that a\n file or class name and description of purpose be included on the\n same \"printed page\" as the copyright notice for easier\n identification within third-party archives.\n\n Copyright [yyyy] [name of copyright owner]\n\n Licensed under the Apache License, Version 2.0 (the \"License\");\n you may not use this file except in compliance with the License.\n You may obtain a copy of the License at\n\n http://www.apache.org/licenses/LICENSE-2.0\n\n Unless required by applicable law or agreed to in writing, software\n distributed under the License is distributed on an \"AS IS\" BASIS,\n WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.\n See the License for the specific language governing permissions and\n limitations under the License.\n" }, { "path": "README.org", "content": "[[http://melpa.org/#/fsharp-mode][file:http://melpa.org/packages/fsharp-mode-badge.svg]]\n[[https://stable.melpa.org/#/fsharp-mode][file:https://stable.melpa.org/packages/fsharp-mode-badge.svg]]\n[[https://github.com/fsharp/emacs-fsharp-mode/actions][file:https://github.com/fsharp/emacs-fsharp-mode/workflows/CI/badge.svg]]\n* fsharp-mode\n\nProvides support for the F# language in Emacs. Includes the following features:\n\n- Syntax highlighting and indentation\n- Support for F# Interactive\n- Via [[https://github.com/joaotavora/eglot/issues][Eglot]] LSP-client integration:\n - Displays type signatures and tooltips\n - Flymake\n - Completion\n - Jump to definition [[https://www.gnu.org/software/emacs/manual/html_node/emacs/Xref.html][Find Identifier References]] (Xref)\n\n\n** Project Status\n\nThis implementation is based on a very old OCaml-mode codebase and has become increasingly difficult to maintain.\nFuture development efforts should focus on [[https://github.com/bbatsov/fsharp-ts-mode][fsharp-ts-mode · GitHub]]\nwhich is built on modern Emacs features, leveraging Tree-Sitter support.\n\n** LSP mode\n\nThe current version of =fsharp-mode= installs =fsautocomplete.exe=\nautomatically via =eglot-fsharp.el= (part of this mono repo, [[https://melpa.org/#/eglot-fsharp][eglot-fsharp\non melpa]]) or [[https://github.com/emacs-lsp/lsp-mode][lsp-mode]] (untested).\n\n=fsharp-mode= is tested with Emacs 27.1+ and NET Core 6 (LTS)\n\n** Installation\n\n*** Package\n\n=fsharp-mode= is available on [[https://melpa.org][MELPA]] and can\nbe installed using the built-in package manager.\n\nIf you're not already using MELPA, add the following to your init.el:\n\n#+BEGIN_SRC elisp\n ;;; Initialize MELPA\n (require 'package)\n (add-to-list 'package-archives '(\"melpa\" . \"http://melpa.org/packages/\"))\n (unless package-archive-contents (package-refresh-contents))\n (package-initialize)\n\n ;;; Install fsharp-mode\n (unless (package-installed-p 'fsharp-mode)\n (package-install 'fsharp-mode))\n\n (require 'fsharp-mode)\n#+END_SRC\n\nIf you are a user of [[https://github.com/jwiegley/use-package][use-package]] you can instead do\n\n#+BEGIN_SRC elisp\n(use-package fsharp-mode\n :defer t\n :ensure t)\n#+END_SRC\n\n*** From source\n\nI recommend to use [[https://cask.github.io/why-cask.html][Cask]]. Add this to your =Cask= file:\n\n#+BEGIN_SRC elisp\n(depends-on \"fsharp-mode\" :git \"https://github.com/fsharp/emacs-fsharp-mode.git\")\n#+END_SRC\n\n** Eglot integration\n\nThe =eglot-fsharp= integration is not part of [[https://melpa.org/#/fsharp-mode][fsharp-mode on melpa]].\n\nIt is available via the seperate package [[https://melpa.org/#/eglot-fsharp][eglot-fsharp on melpa]].\n\nAdd to your config:\n#+BEGIN_SRC elisp\n(require 'eglot-fsharp)\n#+END_SRC\n\nand execute =M-x eglot=\n\nWith 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]])\n\n\n** Projects\n\n=fsharp-mode= has support for Emacs build-in project management via =project.el=\n\n** Configuration\n\n*** Compiler and REPL paths\n\nThe F# compiler and interpreter should be set to good defaults for\nyour OS as long as the relevant executables can be found on your PATH\nor in other standard locations. If you have a non-standard setup you\nmay need to configure these paths manually.\n\nOn Windows:\n\n#+BEGIN_SRC elisp\n(setq inferior-fsharp-program \"c:\\\\Path\\\\To\\\\Fsi.exe\")\n#+END_SRC\n\nOn Unix-like systems, you must use the *--readline-* flag to ensure F#\nInteractive will work correctly with Emacs. Typically =fsi= and =fsc= are\ninvoked through the shell scripts =fsharpi= and =fsharpc=:\n\n#+BEGIN_SRC elisp\n(setq inferior-fsharp-program \"path/to/fsharpi --readline-\")\n#+END_SRC\n\n*** Key Bindings\n\nIf you are new to Emacs, you might want to use the menu (call\n=menu-bar-mode= if you don't see it). However, it's usually faster to learn\na few useful bindings:\n\n| Key binding | Description |\n|------------------+-------------------------------------------|\n| =C-c C-r= | Evaluate region |\n| =C-c C-f= | Load current buffer into toplevel |\n| =C-c C-e= | Evaluate current toplevel phrase |\n| =C-M-x= | Evaluate current toplevel phrase |\n| =C-M-h= | Mark current toplevel phrase |\n| =C-c C-s= | Show interactive buffer |\n| =C-c C-c= | Compile with fsc |\n| =C-c x= | Run the executable |\n| =C-c C-a= | Open alternate file (.fsi or .fs) |\n| =C-c l= | Shift region to left |\n| =C-c r= | Shift region to right |\n| =C-c = | Move cursor to the beginning of the block |\n| =C-c C-d=, =M-.= | Jump to definition of symbol at point |\n| =C-c C-b=, =M-,= | Return to where point was before jump. |\n\n\nTo interrupt the interactive mode, use =C-c C-c=. This is useful if your\ncode does an infinite loop or a very long computation.\n\nIf you want to shift the region by 2 spaces, use: =M-2 C-c r=\n\nIn the interactive buffer, use ==M-RET= to send the code without\nexplicitly adding the =;;= thing.\n\n\n** Editor\n\nIn order to change tab size it is possible to put this in emacs profile:\n\n#+BEGIN_SRC elisp\n(setq-default fsharp-indent-offset 2)\n#+END_SRC\n\nBecause the F# language is sensitive to indentation, you might wan't to highlight indentation:\n\n#+BEGIN_SRC elisp\n(add-hook 'fsharp-mode-hook 'highlight-indentation-mode)\n#+END_SRC\n\n** Troubleshooting\n\n=fsharp-mode= is still under development, so you may encounter some\nissues. Please report them so we can improve things! Open an issue on [[https://github.com/fsharp/emacs-fsharp-mode/][Github]].\n\n*** No autocompletion in FSX files\n\nThe 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]]\n\nAs a workaround can add a reference to the facade netstandard assembly (path is platform/SDK-dependent).\n\nOn Arch Linux using [[https://aur.archlinux.org/packages/dotnet-sdk-lts-bin][dotnet sdk lts]] add this to your =fsx= file:\n#+BEGIN_SRC fsharp\n#r \"/opt/dotnet/sdk/2.1.801/ref/netstandard.dll\"\n#+END_SRC\n\n*** Project file issues\n\nIf your project file does not seem to be being parsed correctly, so\nthat you have missing references or other incorrect intellisense\nresults, it is possible to obtain a detailed log of LSP events in this buffers:\n\n\n- =*EGLOT (PROJECT/fsharp-mode) stderr*=\n- =*EGLOT (PROJECT/fsharp-mode) output*=\n- =*EGLOT (PROJECT/fsharp-mode) events*=\n\n** Contributing\n\nThis project is maintained by the\n[[http://fsharp.org/][F# Software Foundation]], with the repository hosted\non [[https://github.com/fsharp/emacs-fsharp-mode][GitHub]].\n\nPull requests are welcome. Please run the test-suite with [[https://doublep.github.io/eldev/][Eldev]] =eldev -dtT test=\nbefore submitting a pull request.\n\n*** Maintainers\n\nThe maintainers of this repository appointed by the F# Core Engineering Group are:\n\n - [[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]]\n - The primary maintainer for this repository is [[https://github.com/juergenhoetzel][Jürgen Hötzel]]\n\nPrevious maintainers:\n - [[https://github.com/rneatherway][Robin Neatherway]]\n\n\n\n\n" }, { "path": "eglot-fsharp.el", "content": ";;; eglot-fsharp.el --- fsharp-mode eglot integration -*- lexical-binding: t; -*-\n\n;; Copyright (C) 2019-2024 Jürgen Hötzel\n\n;; Author: Jürgen Hötzel \n;; Package-Requires: ((emacs \"27.1\") (eglot \"1.4\") (fsharp-mode \"1.10\") (jsonrpc \"1.0.14\"))\n;; Version: 1.10\n;; Keywords: languages\n;; URL: https://github.com/fsharp/emacs-fsharp-mode\n\n;; This program is free software; you can redistribute it and/or modify\n;; it under the terms of the GNU General Public License as published by\n;; the Free Software Foundation, either version 3 of the License, or\n;; (at your option) any later version.\n\n;; This program is distributed in the hope that it will be useful,\n;; but WITHOUT ANY WARRANTY; without even the implied warranty of\n;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n;; GNU General Public License for more details.\n\n;; You should have received a copy of the GNU General Public License\n;; along with this program. If not, see .\n\n;;; Commentary:\n\n;; Lua eglot introduced\n\n;;; Code:\n\n(require 'eglot)\n(require 'fsharp-mode)\n(require 'gnutls)\n\n(defgroup eglot-fsharp nil\n \"LSP support for the F# Programming Language, using F# compiler service.\"\n :link '(url-link \"https://github.com/fsharp/FsAutoComplete\")\n :group 'eglot)\n\n(defcustom eglot-fsharp-server-path \"~/.dotnet/tools/\"\n \"Path to the location of FsAutoComplete.\"\n :group 'eglot-fsharp\n :risky t)\n\n(defcustom eglot-fsharp-server-install-dir\n (locate-user-emacs-file \"FsAutoComplete/\")\n \"Install directory for FsAutoComplete.\"\n :group 'eglot-fsharp\n :risky t\n :type '(choice directory (const :tag \"Use dotnet default for tool-path\" nil)))\n\n(defcustom eglot-fsharp-server-version 'latest\n \"FsAutoComplete version to install or update.\"\n :group 'eglot-fsharp\n :risky t\n :type '(choice\n (const :tag \"Latest release\" latest)\n (string :tag \"Version string\")))\n\n(defcustom eglot-fsharp-server-args '(\"--adaptive-lsp-server-enabled\")\n \"Arguments for the fsautocomplete command when using `eglot-fsharp'.\"\n :type '(repeat string))\n\n(defcustom eglot-fsharp-fsautocomplete-args '(\n :automaticWorkspaceInit t\n :abstractClassStubGeneration t\n\t\t\t\t :abstractClassStubGenerationMethodBody\n\t\t\t\t \"failwith \\\"Not Implemented\\\"\"\n\t\t\t\t :abstractClassStubGenerationObjectIdentifier \"this\"\n\t\t\t\t :addFsiWatcher nil\n\t\t\t\t :codeLenses (:references (:enabled t)\n\t\t\t\t\t\t\t :signature (:enabled t))\n\t\t\t\t :disableFailedProjectNotifications nil\n\t\t\t\t :dotnetRoot \"\"\n\t\t\t\t :enableAdaptiveLspServer t\n\t\t\t\t :enableAnalyzers nil\n\t\t\t\t :enableMSBuildProjectGraph nil\n\t\t\t\t :enableReferenceCodeLens t\n\t\t\t\t :excludeProjectDirectories [\".git\" \"paket-files\" \".fable\" \"packages\" \"node_modules\"]\n\t\t\t\t :externalAutocomplete nil\n\t\t\t\t :fsac (:attachDebugger nil\n :cachedTypeCheckCount 200\n\t\t\t\t :conserveMemory nil\n\t\t\t\t :dotnetArgs nil\n\t\t\t\t :netCoreDllPath \"\"\n\t\t\t\t :parallelReferenceResolution nil\n\t\t\t\t :silencedLogs nil)\n\t\t\t\t :fsiExtraParameters nil\n\t\t\t\t :fsiSdkFilePath \"\"\n\t\t\t\t :generateBinlog nil\n\t\t\t\t :indentationSize 4\n\t\t\t\t :inlayHints (:disableLongTooltip nil\n\t\t\t\t\t\t\t\t :enabled t\n\t\t\t\t\t\t\t\t :parameterNames t\n\t\t\t\t\t\t\t\t :typeAnnotations t)\n\t\t\t\t :inlineValues (:enabled nil\n\t\t\t\t\t\t\t :prefix \"//\")\n\t\t\t\t :interfaceStubGeneration t\n\t\t\t\t :interfaceStubGenerationMethodBody \"failwith \\\"Not Implemented\\\"\"\n\t\t\t\t :interfaceStubGenerationObjectIdentifier \"this\"\n\t\t\t\t :keywordsAutocomplete t\n\t\t\t\t :lineLens (:enabled \"replaceCodeLens\"\n\t\t\t\t\t :prefix \" // \")\n\t\t\t\t :linter t\n\t\t\t\t :pipelineHints (:enabled t\n\t\t\t\t\t\t\t :prefix \" // \")\n\t\t\t\t :recordStubGeneration t\n\t\t\t\t :recordStubGenerationBody \"failwith \\\"Not Implemented\\\"\"\n\t\t\t\t :resolveNamespaces t\n\t\t\t\t :saveOnSendLastSelection nil\n\t\t\t\t :simplifyNameAnalyzer t\n\t\t\t\t :smartIndent nil\n\t\t\t\t :suggestGitignore t\n\t\t\t\t :suggestSdkScripts t\n\t\t\t\t :unionCaseStubGeneration t\n\t\t\t\t :unionCaseStubGenerationBody \"failwith \\\"Not Implemented\\\"\"\n\t\t\t\t :unusedDeclarationsAnalyzer t\n\t\t\t\t :unusedOpensAnalyzer t\n\t\t\t\t :verboseLogging nil\n\t\t\t\t :workspaceModePeekDeepLevel 4\n\t\t\t\t :workspacePath \"\")\n \"Arguments for the fsautocomplete workspace configuration.\"\n :group 'eglot-fsharp\n :risky t\n )\n\n(defun eglot-fsharp--path-to-server ()\n \"Return FsAutoComplete path.\"\n (let ((base (if eglot-fsharp-server-install-dir\n (concat eglot-fsharp-server-install-dir \"netcore/\")\n eglot-fsharp-server-path)))\n (expand-file-name (concat base \"fsautocomplete\" (if (eq system-type 'windows-nt) \".exe\" \"\")))))\n\n;; cache to prevent repetitive queries\n(defvar eglot-fsharp--latest-version nil \"Latest fsautocomplete.exe version string.\")\n\n(defun eglot-fsharp--latest-version ()\n \"Return latest fsautocomplete.exe version.\"\n (let* ((json (with-temp-buffer (url-insert-file-contents \"https://azuresearch-usnc.nuget.org/query?q=fsautocomplete&prerelease=false&packageType=DotnetTool\")\n\t\t\t (json-parse-buffer)))\n (versions (gethash \"versions\" (aref (gethash \"data\" json) 0))))\n (gethash \"version\" (aref versions (1- (length versions))))))\n\n(defun eglot-fsharp--installed-version ()\n \"Return version string of fsautocomplete.\"\n (with-temp-buffer\n (if eglot-fsharp-server-install-dir\n (process-file \"dotnet\" nil t nil \"tool\" \"list\" \"--tool-path\" (file-name-directory (eglot-fsharp--path-to-server)))\n (process-file \"dotnet\" nil t nil \"tool\" \"list\" \"-g\"))\n (goto-char (point-min))\n (when (search-forward-regexp \"^fsautocomplete[[:space:]]+\\\\([0-9\\.]*\\\\)[[:space:]]+\" nil t)\n (match-string 1))))\n\n(defun eglot-fsharp-current-version-p (version)\n \"Return t if the installation is up-to-date compared to VERSION string.\"\n (and (file-exists-p (concat (file-remote-p default-directory) (eglot-fsharp--path-to-server)))\n (equal version (eglot-fsharp--installed-version))))\n\n(defun eglot-fsharp--install-core (version)\n \"Download and install fsautocomplete as a dotnet tool at version VERSION in `eglot-fsharp-server-install-dir'.\"\n (let* ((default-directory (concat (file-remote-p default-directory)\n (file-name-directory (eglot-fsharp--path-to-server))))\n (stderr-file (make-temp-file \"dotnet_stderr\"))\n (local-tool-path (or (file-remote-p default-directory 'localname) default-directory))\n (process-file-uninstall-args (if eglot-fsharp-server-install-dir\n (list \"dotnet\" nil `(nil ,stderr-file) nil \"tool\" \"uninstall\" \"fsautocomplete\" \"--tool-path\" local-tool-path)\n (list \"dotnet\" nil `(nil ,stderr-file) nil \"tool\" \"uninstall\" \"-g\" \"fsautocomplete\")))\n (process-file-install-args (if eglot-fsharp-server-install-dir\n (list \"dotnet\" nil `(nil ,stderr-file) nil \"tool\" \"install\" \"fsautocomplete\" \"--tool-path\" local-tool-path \"--version\" version)\n (list \"dotnet\" nil `(nil ,stderr-file) nil \"tool\" \"install\" \"fsautocomplete\" \"-g\" \"--version\" version))))\n (make-directory default-directory t)\n (condition-case err\n (progn\n (unless (or (eglot-fsharp-current-version-p version) (not (eglot-fsharp--installed-version)))\n (message \"Uninstalling fsautocomplete version %s\" (eglot-fsharp--installed-version))\n (unless (zerop (apply #'process-file process-file-uninstall-args))\n (error \"'dotnet tool uninstall fsautocomplete ... failed\")))\n (unless (zerop (apply #'process-file process-file-install-args))\n (error \"'dotnet tool install fsautocomplete --tool-path %s --version %s' failed\" default-directory version)))\n (error\n (let ((stderr (with-temp-buffer\n (insert-file-contents stderr-file)\n (buffer-string))))\n (delete-file stderr-file)\n (signal (car err) (format \"%s: %s\" (cdr err) stderr)))))\n (message \"Installed fsautocomplete to %s\" (eglot-fsharp--path-to-server))))\n\n(defun eglot-fsharp--maybe-install (&optional version)\n \"Downloads F# compiler service, and install in `eglot-fsharp-server-install-dir'.\"\n (unless eglot-fsharp-server-install-dir\n (make-directory (concat (file-remote-p default-directory)\n (file-name-directory (eglot-fsharp--path-to-server))) t))\n (let* ((version (or version (if (eq eglot-fsharp-server-version 'latest)\n\t\t\t\t (eglot-fsharp--latest-version)\n\t\t\t\teglot-fsharp-server-version))))\n (unless (eglot-fsharp-current-version-p version)\n (eglot-fsharp--install-core version))))\n\n;;;###autoload\n(defun eglot-fsharp (interactive)\n \"Return `eglot' contact when FsAutoComplete is installed.\nEnsure FsAutoComplete is installed (when called INTERACTIVE).\"\n (when interactive (eglot-fsharp--maybe-install))\n (cons 'eglot-fsautocomplete\n (if (file-remote-p default-directory)\n `(\"sh\" ,shell-command-switch ,(concat \"cat|\" (mapconcat #'shell-quote-argument\n (cons (eglot-fsharp--path-to-server) eglot-fsharp-server-args) \" \")))\n (cons (eglot-fsharp--path-to-server) eglot-fsharp-server-args))))\n\n\n(defclass eglot-fsautocomplete (eglot-lsp-server) ()\n :documentation \"F# FsAutoComplete langserver.\")\n\n(cl-defmethod eglot-initialization-options ((_server eglot-fsautocomplete))\n \"Passes through required FsAutoComplete initialization options.\"\n eglot-fsharp-fsautocomplete-args)\n\n;; FIXME: this should be fixed in FsAutocomplete\n(cl-defmethod xref-backend-definitions :around ((_type symbol) _identifier)\n \"FsAutoComplete breaks spec and and returns error instead of empty list.\"\n (if (eq major-mode 'fsharp-mode)\n (condition-case err\n (cl-call-next-method)\n (jsonrpc-error\n (not (equal (cadddr err) '(jsonrpc-error-message . \"Could not find declaration\")))))\n (when (cl-next-method-p)\n (cl-call-next-method))))\n\n(add-to-list 'eglot-server-programs `(fsharp-mode . eglot-fsharp))\n\n(provide 'eglot-fsharp)\n;;; eglot-fsharp.el ends here\n" }, { "path": "fsharp-mode-font.el", "content": ";;; fsharp-mode-font.el --- Syntax highlighting for F#\n\n;; Copyright (C) 1997 INRIA\n\n;; Author: 1993-1997 Xavier Leroy, Jacques Garrigue and Ian T Zimmerman\n;; 2010-2011 Laurent Le Brun \n;; Maintainer: Robin Neatherway \n;; Keywords: languages\n\n;; This file is not part of GNU Emacs.\n\n;; This file is free software; you can redistribute it and/or modify\n;; it under the terms of the GNU General Public License as published by\n;; the Free Software Foundation; either version 3, or (at your option)\n;; any later version.\n\n;; This file is distributed in the hope that it will be useful,\n;; but WITHOUT ANY WARRANTY; without even the implied warranty of\n;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n;; GNU General Public License for more details.\n\n;; You should have received a copy of the GNU General Public License\n;; along with GNU Emacs; see the file COPYING. If not, write to\n;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,\n;; Boston, MA 02110-1301, USA.\n\n;;; Commentary:\n\n;;; Code:\n\n(defgroup fsharp-ui nil\n \"F# UI group for the defcustom interface.\"\n :prefix \"fsharp-ui-\"\n :group 'fsharp\n :package-version '(fsharp-mode . \"1.9.2\"))\n\n(defface fsharp-ui-generic-face\n '((t (:inherit default)))\n \"Preprocessor face\"\n :group 'fsharp-ui)\n\n(defface fsharp-ui-operator-face\n '((t (:foreground \"LightSkyBlue\")))\n \"Preprocessor face\"\n :group 'fsharp-ui)\n\n(defface fsharp-ui-warning-face\n '((t (:inherit font-lock-warning-face)))\n \"Face for warnings.\"\n :group 'fsharp-ui)\n\n(defface fsharp-ui-error-face\n '((t (:inherit font-lock-error-face :underline t)))\n \"Face for errors\"\n :group 'fsharp-ui)\n\n(defmacro def-fsharp-compiled-var (sym init &optional docstring)\n \"Defines a SYMBOL as a constant inside an eval-and-compile form\nwith initial value INITVALUE and optional DOCSTRING.\"\n `(eval-and-compile\n (defvar ,sym ,init ,docstring)))\n\n(def-fsharp-compiled-var fsharp-shebang-regexp\n \"\\\\(^#!.*?\\\\)\\\\([A-Za-z0-9_-]+\\\\)$\"\n \"Capture the #! and path of a shebag in one group and the\n executable in another.\")\n\n(def-fsharp-compiled-var fsharp-access-control-regexp\n \"private\\\\s-+\\\\|internal\\\\s-+\\\\|public\\\\s-+\"\n \"Match `private', `internal', or `public', followed by a space,\n with no capture.\")\n\n(def-fsharp-compiled-var fsharp-access-control-regexp-noncapturing\n (format \"\\\\(?:%s\\\\)\" fsharp-access-control-regexp)\n \"Same as `fsharp-access-control-regexp', but captures\")\n\n(def-fsharp-compiled-var fsharp-inline-rec-regexp\n \"inline\\\\s-+\\\\|rec\\\\s-+\"\n \"Match `inline' or `rec', followed by a space.\")\n\n(def-fsharp-compiled-var fsharp-inline-rec-regexp-noncapturing\n (format \"\\\\(?:%s\\\\)\" fsharp-inline-rec-regexp)\n \"Match `inline' or `rec', followed by a space, with no capture.\")\n\n(def-fsharp-compiled-var fsharp-valid-identifier-regexp\n \"[A-Za-z0-9_']+\"\n \"Match a normal, valid F# identifier -- alphanumeric characters\n plus ' and underbar. Does not capture\")\n\n(def-fsharp-compiled-var fsharp-function-def-regexp\n (concat \"\\\\<\\\\(?:let\\\\|and\\\\|with\\\\)\\\\s-+\"\n fsharp-inline-rec-regexp-noncapturing \"?\"\n fsharp-access-control-regexp-noncapturing \"*\"\n (format \"\\\\(%s\\\\)\" fsharp-valid-identifier-regexp)\n \"\\\\(?:\\\\s-+[A-Za-z_]\\\\|\\\\s-*(\\\\)\" ;; matches function arguments or open-paren; unclear why 0-9 not in class\n ))\n\n(def-fsharp-compiled-var fsharp-pattern-function-regexp\n (concat \"\\\\<\\\\(?:let\\\\|and\\\\)\\\\s-+\"\n fsharp-inline-rec-regexp-noncapturing \"?\"\n fsharp-access-control-regexp-noncapturing \"*\"\n (format \"\\\\(%s\\\\)\" fsharp-valid-identifier-regexp)\n \"\\\\s-*=\\\\s-*function\")\n \"Matches an implicit matcher, eg let foo m = function | \\\"cat\\\" -> etc.\")\n\n;; Note that this regexp is used for iMenu. To font-lock active patterns, we\n;; need to use an anchored match in fsharp-font-lock-keywords.\n(def-fsharp-compiled-var fsharp-active-pattern-regexp\n (concat \"\\\\<\\\\(?:let\\\\|and\\\\)\\\\s-+\"\n fsharp-inline-rec-regexp-noncapturing \"?\"\n fsharp-access-control-regexp-noncapturing \"*\"\n \"(\\\\(|[A-Za-z0-9_'|]+|\\\\))\\\\(?:\\\\s-+[A-Za-z_]\\\\|\\\\s-*(\\\\)\"))\n\n(def-fsharp-compiled-var fsharp-member-access-regexp\n \"\\\\<\\\\(?:override\\\\|member\\\\|abstract\\\\)\\\\s-+\"\n \"Matches members declarations and modifiers on classes.\")\n\n(def-fsharp-compiled-var fsharp-member-function-regexp\n (concat fsharp-member-access-regexp\n fsharp-inline-rec-regexp-noncapturing \"?\"\n fsharp-access-control-regexp-noncapturing \"*\"\n \"\\\\(?:\" fsharp-valid-identifier-regexp \"\\\\.\\\\)?\"\n \"\\\\(\" fsharp-valid-identifier-regexp \"\\\\)\")\n \"Captures the final identifier in a member function declaration.\")\n\n(def-fsharp-compiled-var fsharp-overload-operator-regexp\n (concat fsharp-member-access-regexp\n fsharp-inline-rec-regexp-noncapturing \"?\"\n fsharp-access-control-regexp-noncapturing \"*\"\n \"\\\\(([!%&*+-./<=>?@^|~]+)\\\\)\")\n \"Match operators when overloaded by a type/class.\")\n\n(def-fsharp-compiled-var fsharp-constructor-regexp\n (concat \"^\\\\s-*\"\n fsharp-access-control-regexp-noncapturing \"*\"\n \"\\\\<\\\\(new\\\\) *(.*)[^=]*=\")\n \"Matches the `new' keyword in a constructor\")\n\n(def-fsharp-compiled-var fsharp-type-def-regexp\n (concat \"^\\\\s-*\\\\<\\\\(?:type\\\\|inherit\\\\)\\\\s-+\"\n fsharp-access-control-regexp-noncapturing \"*\" ;; match access control 0 or more times\n \"\\\\([A-Za-z0-9_'.]+\\\\)\"))\n\n(def-fsharp-compiled-var fsharp-var-or-arg-regexp\n \"\\\\_<\\\\([A-Za-z_][A-Za-z0-9_']*\\\\)\\\\_>\")\n\n(def-fsharp-compiled-var fsharp-explicit-field-regexp\n (concat \"^\\\\s-*\\\\(?:val\\\\|abstract\\\\)\\\\s-*\\\\(?:mutable\\\\s-+\\\\)?\"\n fsharp-access-control-regexp-noncapturing \"*\" ;; match access control 0 or more times\n \"\\\\([A-Za-z_][A-Za-z0-9_']*\\\\)\\\\s-*:\\\\s-*\\\\([A-Za-z_][A-Za-z0-9_'<> \\t]*\\\\)\"))\n\n(def-fsharp-compiled-var fsharp-attributes-regexp\n \"\\\\(\\\\[<[A-Za-z0-9_]+[( ]?\\\\)\\\\(\\\".*\\\"\\\\)?\\\\()?>\\\\]\\\\)\"\n \"Match attributes like []; separately groups contained strings in attributes like []\")\n\n;; F# makes extensive use of operators, many of which have some kind of\n;; structural significance.\n;;\n;; In particular:\n;; (| ... |) -- banana clips for Active Patterns (handled separately)\n;; <@ ... @> and <@@ ... @@> -- quoted expressions\n;; <| and |> -- left and right pipe (also <||, <|||, ||>, |||>)\n;; << and >> -- function composition\n;; | -- match / type expressions\n\n(def-fsharp-compiled-var fsharp-operator-quote-regexp\n \"\\\\(<@\\\\{1,2\\\\}\\\\)\\\\(?:.*\\\\)\\\\(@\\\\{1,2\\\\}>\\\\)\"\n \"Font lock <@/<@@ and @>/@@> operators.\")\n\n(def-fsharp-compiled-var fsharp-operator-pipe-regexp\n \"<|\\\\{1,3\\\\}\\\\||\\\\{1,3\\\\}>\"\n \"Match the full range of pipe operators -- |>, ||>, |||>, etc.\")\n\n(def-fsharp-compiled-var fsharp-custom-operator-with-pipe-regexp\n (let ((op-chars \"!%&\\\\*\\\\+\\\\-\\\\./<=>@\\\\^~\") ;; all F# custom operator chars except for `|`\n (backward-pipe \"<|\\\\{1,3\\\\}\")\n (forward-pipe \"|\\\\{1,3\\\\}>\")\n (alt \"\\\\|\"))\n (concat \"[\" op-chars \"|]*\" backward-pipe \"[\" op-chars \"]+\"\n alt \"[\" op-chars \"|]+\" backward-pipe \"[\" op-chars \"]*\"\n alt \"[\" op-chars \"]*\" forward-pipe \"[\" op-chars \"|]+\"\n alt \"[\" op-chars \"]+\" forward-pipe \"[\" op-chars \"|]*\"))\n \"Match operators that contains pipe sequence -- <|>, |>>, <<|, etc.\")\n\n(def-fsharp-compiled-var fsharp-operator-case-regexp\n \"\\\\s-+\\\\(|\\\\)[A-Za-z0-9_' ]\"\n \"Match literal | in contexts like match and type declarations.\")\n\n(defvar fsharp-imenu-generic-expression\n `((nil ,(concat \"^\\\\s-*\" fsharp-function-def-regexp) 1)\n (nil ,(concat \"^\\\\s-*\" fsharp-pattern-function-regexp) 1)\n (\"Active Pattern\" ,(concat \"^\\\\s-*\" fsharp-active-pattern-regexp) 1)\n (\"Member\" ,(concat \"^\\\\s-*\" fsharp-member-function-regexp) 1)\n (\"Overload Operator\" ,(concat \"^\\\\s-*\" fsharp-overload-operator-regexp) 1)\n (\"Constructor\" ,fsharp-constructor-regexp 1)\n (\"Type\" ,fsharp-type-def-regexp 1)\n (\"Module\" ,(concat \"\\\\s-*module \" fsharp-var-or-arg-regexp) 1))\n\n \"Provide iMenu support through font-locking regexen.\")\n\n(defun fsharp-imenu-load-index ()\n \"Hook up the provided regexen to enable imenu support.\"\n (setq imenu-generic-expression fsharp-imenu-generic-expression))\n\n(add-hook 'fsharp-mode-hook #'fsharp-imenu-load-index)\n\n(defun fsharp-var-pre-form ()\n (save-excursion\n (re-search-forward \"\\\\(:\\\\s-*\\\\w[^)]*\\\\)?=\" nil t)\n (match-beginning 0)))\n\n(defun fsharp-fun-pre-form ()\n (save-excursion\n (search-forward \"->\")))\n\n;; Preprocessor directives (3.3)\n(def-fsharp-compiled-var fsharp-ui-preproessor-directives\n '(\"#if\" \"#else\" \"#endif\" \"#light\"))\n\n;; Compiler directives (12.4)\n(def-fsharp-compiled-var fsharp-ui-compiler-directives\n '(\"#nowarn\" \"#load\" \"#r\" \"#reference\" \"#I\"\n \"#Include\" \"#q\" \"#quit\" \"#time\" \"#help\"))\n\n;; Lexical matters (18.4)\n(def-fsharp-compiled-var fsharp-ui-lexical-matters\n '(\"#indent\"))\n\n;; Line Directives (3.9)\n(def-fsharp-compiled-var fsharp-ui-line-directives\n '(\"#line\"))\n\n;; Identifier replacements (3.11)\n(def-fsharp-compiled-var fsharp-ui-identifier-replacements\n '(\"__SOURCE_DIRECTORY__\" \"__SOURCE_FILE__\" \"__LINE__\"))\n\n;; F# keywords (5.0)\n(def-fsharp-compiled-var fsharp-ui-fsharp-threefour-keywords\n '(\"abstract\" \"and\" \"and!\" \"as\" \"assert\" \"base\" \"begin\"\n \"class\" \"default\" \"delegate\" \"do\" \"do!\" \"done\"\n \"downcast\" \"downto\" \"elif\" \"else\" \"end\"\n \"exception\" \"extern\" \"false\" \"finally\" \"for\" \"fun\"\n \"function\" \"global\" \"if\" \"in\" \"inherit\" \"inline\"\n \"interface\" \"internal\" \"lazy\" \"let\" \"let!\"\n \"match\" \"match!\" \"member\" \"module\" \"mutable\" \"namespace\"\n \"new\" \"not\" \"null\" \"of\" \"open\" \"or\" \"override\"\n \"private\" \"public\" \"rec\" \"return\" \"return!\"\n \"select\" \"static\" \"struct\" \"then\" \"to\" \"true\"\n \"try\" \"type\" \"upcast\" \"use\" \"use!\" \"val\" \"void\"\n \"when\" \"while\" \"with\" \"yield\" \"yield!\"))\n\n;; \"Reserved because they are reserved in OCaml\"\n(def-fsharp-compiled-var fsharp-ui-ocaml-reserved-words\n '(\"asr\" \"land\" \"lor\" \"lsl\" \"lsr\" \"lxor\" \"mod\" \"sig\"))\n\n;; F# reserved words for future use\n(def-fsharp-compiled-var fsharp-ui-reserved-words\n '(\"atomic\" \"break\" \"checked\" \"component\" \"const\"\n \"constraint\" \"constructor\" \"continue\" \"eager\"\n \"event\" \"external\" \"fixed\" \"functor\" \"include\"\n \"method\" \"mixin\" \"object\" \"parallel\" \"process\"\n \"protected\" \"pure\" \"sealed\" \"tailcall\" \"trait\"\n \"virtual\" \"volatile\"))\n\n;; RMD 2016-09-30 -- This was pulled out separately with the following comment\n;; when I got here. Not clear to me why it's on it's own, or even precisely what\n;; the comment means. But: `async' is a valid F# keyword and needs to go someplace,\n;; so I've left it here. For now.\n;;\n;; Workflows not yet handled by fsautocomplete but async\n;; always present\n(def-fsharp-compiled-var fsharp-ui-async-words\n '(\"async\")\n \"Just the word async, in a list.\")\n\n(def-fsharp-compiled-var fsharp-ui-word-list-regexp\n (regexp-opt\n `(,@fsharp-ui-async-words\n ,@fsharp-ui-compiler-directives\n ,@fsharp-ui-fsharp-threefour-keywords\n ,@fsharp-ui-identifier-replacements\n ,@fsharp-ui-lexical-matters\n ,@fsharp-ui-ocaml-reserved-words\n ,@fsharp-ui-preproessor-directives\n ,@fsharp-ui-reserved-words\n ,@fsharp-ui-line-directives)\n 'symbols))\n\n(defconst fsharp-font-lock-keywords\n (eval-when-compile\n `((,fsharp-ui-word-list-regexp 0 font-lock-keyword-face)\n ;; shebang\n (,fsharp-shebang-regexp\n (1 font-lock-comment-face)\n (2 font-lock-keyword-face))\n ;; attributes\n (,fsharp-attributes-regexp\n (1 font-lock-preprocessor-face)\n (2 font-lock-string-face nil t)\n (3 font-lock-preprocessor-face))\n ;; ;; type defines\n (,fsharp-type-def-regexp 1 font-lock-type-face)\n (,fsharp-function-def-regexp 1 font-lock-function-name-face)\n (,fsharp-pattern-function-regexp 1 font-lock-function-name-face)\n ;; Active Pattern\n (\"(|\" (0 'fsharp-ui-operator-face)\n (\"\\\\([A-Za-z'_]+\\\\)\\\\(|)?\\\\)\"\n nil nil\n (1 font-lock-function-name-face)\n (2 'fsharp-ui-operator-face)))\n (,fsharp-custom-operator-with-pipe-regexp . 'fsharp-ui-generic-face)\n (,fsharp-operator-pipe-regexp . 'fsharp-ui-operator-face)\n (,fsharp-member-function-regexp 1 font-lock-function-name-face)\n (,fsharp-overload-operator-regexp 1 font-lock-function-name-face)\n (,fsharp-constructor-regexp 1 font-lock-function-name-face)\n (,fsharp-operator-case-regexp 1 'fsharp-ui-operator-face)\n (,fsharp-operator-quote-regexp (1 'fsharp-ui-operator-face)\n (2 'fsharp-ui-operator-face))\n (\"[^:]:\\\\s-*\\\\(\\\\<[A-Za-z0-9_' ]*[^ ;\\n,)}=<-]\\\\)\\\\(<[^>]*>\\\\)?\"\n (1 font-lock-type-face)\n ;; 'prevent generic type arguments from being rendered in variable face\n (2 'fsharp-ui-generic-face nil t))\n (,(format \"^\\\\s-*\\\\<\\\\(let\\\\|use\\\\|override\\\\|member\\\\|and\\\\|\\\\(?:%snew\\\\)\\\\)\\\\_>\"\n (concat fsharp-access-control-regexp \"*\"))\n (0 font-lock-keyword-face) ; let binding and function arguments\n (,fsharp-var-or-arg-regexp\n (fsharp-var-pre-form) nil\n (1 font-lock-variable-name-face nil t)))\n (\"\\\\\"\n (0 font-lock-keyword-face) ; lambda function arguments\n (,fsharp-var-or-arg-regexp\n (fsharp-fun-pre-form) nil\n (1 font-lock-variable-name-face nil t)))\n (,fsharp-type-def-regexp\n (0 'font-lock-keyword-face) ; implicit constructor arguments\n (,fsharp-var-or-arg-regexp\n (fsharp-var-pre-form) nil\n (1 font-lock-variable-name-face nil t)))\n (,fsharp-explicit-field-regexp\n (1 font-lock-variable-name-face)\n (2 font-lock-type-face))\n\n ;; open namespace\n (\"\\\\@^|~?]*[\\n\\t\\r\\b\\a\\f\\v ]*\\)\" (1 \"()\")) ; symbolic operator starting (* is not a comment\n (\"\\\\(/\\\\)\\\\*\" (1 \".\")))\n start end))\n\n(defun fsharp--syntax-string (end)\n (let* ((pst (syntax-ppss))\n (instr (nth 3 pst))\n (start (nth 8 pst)))\n (when (eq t instr) ; Then we are in a custom string\n (cond\n ((eq ?@ (char-after start)) ; Then we are in a verbatim string\n (while\n (when (re-search-forward \"\\\"\\\"?\" end 'move)\n (if (> (- (match-end 0) (match-beginning 0)) 1)\n t ;; Skip this \"\" and keep looking further.\n (put-text-property (- (match-beginning 0) 1) (- (match-end 0) 1)\n 'syntax-table (string-to-syntax \".\"))\n (put-text-property (match-beginning 0) (match-end 0)\n 'syntax-table (string-to-syntax \"|\"))\n nil))))\n\n (t ; Then we are in a triple-quoted string\n (when (re-search-forward \"\\\"\\\"\\\"\" end 'move)\n (put-text-property (- (match-beginning 0) 1) (match-beginning 0)\n 'syntax-table (string-to-syntax \".\"))\n (put-text-property (match-beginning 0) (match-end 0)\n 'syntax-table (string-to-syntax \"|\"))))))))\n\n(provide 'fsharp-mode-font)\n\n;;; fsharp-mode-font.el ends here\n" }, { "path": "fsharp-mode-structure.el", "content": ";;; fsharp-mode-indent.el --- Stucture Definition, Mark, and Motion for F#\n\n;; Copyright (C) 2010 Laurent Le Brun\n\n;; Author: 2010-2011 Laurent Le Brun \n;; Maintainer: Jürgen Hötzel \n;; Keywords: languages\n\n;; This file is not part of GNU Emacs.\n\n;; This file is free software; you can redistribute it and/or modify\n;; it under the terms of the GNU General Public License as published by\n;; the Free Software Foundation; either version 3, or (at your option)\n;; any later version.\n\n;; This file is distributed in the hope that it will be useful,\n;; but WITHOUT ANY WARRANTY; without even the implied warranty of\n;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n;; GNU General Public License for more details.\n\n;; You should have received a copy of the GNU General Public License\n;; along with GNU Emacs; see the file COPYING. If not, write to\n;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,\n;; Boston, MA 02110-1301, USA.\n\n;;; Commentary:\n;; This module defines variables and functions related to the structure of F#\n;; code, and motion around and through that code. SMIE is used to set certain\n;; default configurations. In particular, `smie' expects to set\n;; `forward-sexp-function' and `indent-line-function', the latter of which we\n;; currently override.\n;;\n;; SMIE configs by m00nlight Wang , 2015\n;; Last major update by Ross Donaldson <@gastove>, 2019\n\n;;; Code:\n\n(require 'comint)\n(require 'custom)\n(require 'compile)\n(require 'smie)\n\n;;-------------------------- Customization Variables --------------------------;;\n\n(defcustom fsharp-tab-always-indent t\n \"*Non-nil means TAB in Fsharp mode should always reindent the current line,\nregardless of where in the line point is when the TAB command is used.\"\n :type 'boolean\n :group 'fsharp)\n\n(defcustom fsharp-indent-offset 4\n \"*Amount of offset per level of indentation.\n`\\\\[fsharp-guess-indent-offset]' can usually guess a good value when\nyou're editing someone else's Fsharp code.\"\n :type 'integer\n :group 'fsharp)\n\n(defalias 'fsharp-indent-level 'fsharp-indent-offset\n \"Backwards-compatibility alias. `fsharp-indent-level' was\n configuring the same thing as `fsharp-indent-offset', but less\n clearly and in a different file, and free from update by\n functions like offset-guessing.\")\n\n(defcustom fsharp-continuation-offset 4\n \"*Additional amount of offset to give for some continuation lines.\nContinuation lines are those that immediately follow a backslash\nterminated line. Only those continuation lines for a block opening\nstatement are given this extra offset.\"\n :type 'integer\n :group 'fsharp)\n\n(defcustom fsharp-conservative-indentation-after-bracket nil\n \"Indent by fsharp-continuation-offset also after an opening bracket.\nThe default indentation depth on a new line after an opening\nbracket is one column further from the opening bracket. Indenting much less is\nallowed, because brackets reset the current offside column.\"\n :type 'boolean\n :group 'fsharp)\n\n(defcustom fsharp-smart-indentation t\n \"*Should `fsharp-mode' try to automagically set some indentation variables?\nWhen this variable is non-nil, two things happen when a buffer is set\nto `fsharp-mode':\n\n 1. `fsharp-indent-offset' is guessed from existing code in the buffer.\n Only guessed values between 2 and 8 are considered. If a valid\n guess can't be made (perhaps because you are visiting a new\n file), then the value in `fsharp-indent-offset' is used.\n\n 2. `indent-tabs-mode' is turned off if `fsharp-indent-offset' does not\n equal `tab-width' (`indent-tabs-mode' is never turned on by\n Fsharp mode). This means that for newly written code, tabs are\n only inserted in indentation if one tab is one indentation\n level, otherwise only spaces are used.\n\nNote that both these settings occur *after* `fsharp-mode-hook' is run,\nso if you want to defeat the automagic configuration, you must also\nset `fsharp-smart-indentation' to nil in your `fsharp-mode-hook'.\"\n :type 'boolean\n :group 'fsharp)\n\n(defcustom fsharp-honor-comment-indentation t\n \"*Controls how comment lines influence subsequent indentation.\n\nWhen nil, all comment lines are skipped for indentation purposes, and\nif possible, a faster algorithm is used (i.e. X/Emacs 19 and beyond).\n\nWhen t, lines that begin with a single `//' are a hint to subsequent\nline indentation. If the previous line is such a comment line (as\nopposed to one that starts with `fsharp-block-comment-prefix'), then its\nindentation is used as a hint for this line's indentation. Lines that\nbegin with `fsharp-block-comment-prefix' are ignored for indentation\npurposes.\n\nWhen not nil or t, comment lines that begin with a single `//' are used\nas indentation hints, unless the comment character is in column zero.\"\n :type '(choice\n (const :tag \"Skip all comment lines (fast)\" nil)\n (const :tag \"Single // `sets' indentation for next line\" t)\n (const :tag \"Single // `sets' indentation except at column zero\"\n other)\n )\n :group 'fsharp)\n\n(defcustom fsharp-backspace-function 'backward-delete-char-untabify\n \"*Function called by `fsharp-electric-backspace' when deleting backwards.\"\n :type 'function\n :group 'fsharp)\n\n(defcustom fsharp-delete-function 'delete-char\n \"*Function called by `fsharp-electric-delete' when deleting forwards.\"\n :type 'function\n :group 'fsharp)\n\n\n;;--------------------------------- Constants ---------------------------------;;\n;; TODO[gastove|2019-10-30] So much:\n;; - No SQTQ in F#\n;; - No raw strings either\n;; - But there *are* verbatim strings that begin with @\n;; - And can use \\ to escape a newline\n;; - But *can* contain newlines\n;; It's a good thing this isn't called often, because it is a mess and wrong.\n(defconst fsharp-stringlit-re\n (concat\n ;; These fail if backslash-quote ends the string (not worth\n ;; fixing?). They precede the short versions so that the first two\n ;; quotes don't look like an empty short string.\n ;;\n ;; (maybe raw), long single quoted triple quoted strings (SQTQ),\n ;; with potential embedded single quotes\n \"[rR]?'''[^']*\\\\(\\\\('[^']\\\\|''[^']\\\\)[^']*\\\\)*'''\"\n \"\\\\|\"\n ;; (maybe raw), long double quoted triple quoted strings (DQTQ),\n ;; with potential embedded double quotes\n \"[rR]?\\\"\\\"\\\"[^\\\"]*\\\\(\\\\(\\\"[^\\\"]\\\\|\\\"\\\"[^\\\"]\\\\)[^\\\"]*\\\\)*\\\"\\\"\\\"\"\n \"\\\\|\"\n \"[rR]?'\\\\([^'\\n\\\\]\\\\|\\\\\\\\.\\\\)*'\" ; single-quoted\n \"\\\\|\" ; or\n \"[rR]?\\\"\\\\([^\\\"\\n\\\\]\\\\|\\\\\\\\.\\\\)*\\\"\" ; double-quoted\n )\n \"Regular expression matching a Fsharp string literal.\")\n\n\n(defconst fsharp--hanging-operator-re\n (concat \".*\\\\(\" (mapconcat 'identity\n '(\"+\" \"-\" \"*\" \"/\")\n \"\\\\|\")\n \"\\\\)$\")\n \"Regular expression matching unterminated algebra expressions.\")\n\n\n;; TODO[gastove|2019-10-22] This doesn't match (* long comments *), but it *does* capture.\n(defconst fsharp-blank-or-comment-re \"[ \\t]*\\\\(//.*\\\\)?\"\n \"Regular expression matching a blank or comment line.\")\n\n(defconst fsharp-outdent-re\n (concat \"\\\\(\" (mapconcat 'identity\n '(\"else\"\n \"with\"\n \"finally\"\n \"end\"\n \"done\"\n \"elif\"\n \"}\")\n \"\\\\|\")\n \"\\\\)\")\n \"Regular expression matching statements to be dedented one level.\")\n\n\n(defconst fsharp-block-closing-keywords-re\n \"\\\\(end\\\\|done\\\\|raise\\\\|failwith\\\\|failwithf\\\\|rethrow\\\\|exit\\\\)\"\n \"Regular expression matching keywords which typically close a block.\")\n\n\n(defconst fsharp-no-outdent-re\n (concat\n \"\\\\(\"\n (mapconcat 'identity\n (list \"try\"\n \"while\\\\s +.*\"\n \"for\\\\s +.*\"\n \"then\"\n (concat fsharp-block-closing-keywords-re \"[ \\t\\n]\")\n )\n \"\\\\|\")\n \"\\\\)\")\n \"Regular expression matching lines not to dedent after.\")\n\n\n(defconst fsharp-block-opening-re\n (concat \"\\\\(\" (mapconcat 'identity\n '(\"then\"\n \"else\"\n \"with\"\n \"finally\"\n \"class\"\n \"struct\"\n \"=\" ; for example: let f x =\n \"->\"\n \"do\"\n \"try\"\n \"function\")\n \"\\\\|\")\n \"\\\\)\")\n \"Regular expression matching expressions which begin a block\")\n\n\n;; TODO: this regexp looks transparently like a python regexp. That means it's almost certainly wrong.\n(defvar fsharp-parse-state-re\n (concat\n \"^[ \\t]*\\\\(elif\\\\|else\\\\|while\\\\|def\\\\|class\\\\)\\\\>\"\n \"\\\\|\"\n \"^[^ /\\t\\n]\"))\n\n\n(defsubst fsharp-point (position)\n \"Returns the value of point at certain commonly referenced POSITIONs.\nPOSITION can be one of the following symbols:\n\n bol -- beginning of line\n eol -- end of line\n bod -- beginning of def or class\n eod -- end of def or class\n bob -- beginning of buffer\n eob -- end of buffer\n boi -- back to indentation\n bos -- beginning of statement\n\nThis function preserves point and mark.\"\n (save-mark-and-excursion\n (cond\n ((eq position 'bol) (beginning-of-line))\n ((eq position 'eol) (end-of-line))\n ((eq position 'bod) (fsharp-beginning-of-def-or-class 'either))\n ((eq position 'eod) (fsharp-end-of-def-or-class 'either))\n ((eq position 'bob) (point-min))\n ((eq position 'eob) (point-max))\n ((eq position 'boi) (back-to-indentation))\n ((eq position 'bos) (fsharp-goto-initial-line))\n (t (error \"Unknown buffer position requested: %s\" position)))\n\n (point)))\n\n\n;;-------------------------------- Predicates --------------------------------;;\n\n(defun fsharp-in-literal-p (&optional lim)\n \"Return non-nil if point is in a Fsharp literal (a comment or\nstring). The return value is specifically one of the symbols\n\\\\='comment or \\\\='string. Optional argument LIM indicates the\nbeginning of the containing form, i.e. the limit on how far back\nto scan.\"\n ;; NOTE: Watch out for infinite recursion between this function and\n ;; `fsharp-point'.\n (let* ((lim (or lim (fsharp-point 'bod)))\n (state (parse-partial-sexp lim (point))))\n (cond\n ((nth 3 state) 'string)\n ((nth 4 state) 'comment)\n (t nil))))\n\n\n(defun fsharp-outdent-p ()\n \"Returns non-nil if the current line should dedent one level.\"\n (save-excursion\n (progn (back-to-indentation)\n (looking-at fsharp-outdent-re))))\n\n\n(defun fsharp--indenting-comment-p ()\n \"Returns non-nil if point is in an indenting comment line, otherwise nil.\n\nDefinition: Indenting comment line. A line containing only a\ncomment, but which is treated like a statement for indentation\ncalculation purposes. Such lines are only treated specially by\nthe mode; they are not treated specially by the Fsharp\ninterpreter.\n\nThe first non-blank line following an indenting comment line is\ngiven the same amount of indentation as the indenting comment\nline.\n\nAll other comment-only lines are ignored for indentation\npurposes.\n\nAre we looking at a comment-only line which is *not* an indenting\ncomment line? If so, we assume that it's been placed at the\ndesired indentation, so leave it alone. Indenting comment lines\nare aligned as statements.\"\n ;; TODO[gastove|2019-10-22] this is a bug. The regular expression here matches\n ;; comments only if there is *no whites space* between the // and the first\n ;; characters in the comment.\n (and (looking-at \"[ \\t]*//[^ \\t\\n]\")\n (fboundp 'forward-comment)\n (<= (current-indentation)\n (save-excursion\n (forward-comment (- (point-max)))\n (current-indentation)))))\n\n\n(defun fsharp--hanging-operator-continuation-line-p ()\n \"Return t if point is on at least the *second* line of the\nbuffer, and the previous line matches `fsharp--hanging-operator-re' --\nwhich is to say, it ends in +, -, /, or *.\"\n (save-excursion\n (beginning-of-line)\n (and\n (not (bobp))\n ;; make sure; since eq test passed, there is a preceding line\n (forward-line -1) ; always true -- side effect\n ;; matches any line, so long as it ends with one of +, -, *, or /\n (looking-at fsharp--hanging-operator-re))))\n\n\n;; TODO[gastove|2019-10-31] This function doesn't do everything it needs to.\n;; Currently, it only reports a continuation line if there's a hanging\n;; arithmetic operator *or* if we're inside a delimited block (something like {}\n;; or []). It _needs_ to also respect symbols that open a new whitespace block\n;; -- things like -> at the end of a line, or |> at the beginning of one.\n;;\n;; The trick is: the other major place where |> and -> lines are considered is\n;; in `fsharp-compute-indentation', which... catches \"undelimited\" blocks as a\n;; default case. They aren't _explicitly_ detected.\n;;\n;; In all, this makes me think we need a cleaner distinction between a\n;; \"continuation line\" and a \"relative line\" -- that is, a line that continues\n;; an ongoing expression (a sequence of items in a list, the completion of an\n;; arithmetic expression) and a new block scope opened by a single symbol and\n;; terminated with whitespace.\n;;\n;; We do already have `fsharp-statement-opens-block-p', which we could make much\n;; more active use of. However: `fsharp-statement-opens-block-p' calls\n;; `fsharp-goto-beyond-final-line', which... relies on\n;; `fsharp-continuation-line-p'. So that will need untangling.\n(defun fsharp-continuation-line-p ()\n \"Return t if current line continues a line with a hanging\narithmetic operator *or* is inside a nesting construct (a list,\ncomputation expression, etc).\"\n (save-excursion\n (beginning-of-line)\n (or (fsharp--hanging-operator-continuation-line-p)\n (fsharp-nesting-level))))\n\n\n(defun fsharp--previous-line-continuation-line-p ()\n \"Returns true if previous line is a continuation line\"\n (save-excursion\n (forward-line -1)\n (fsharp-continuation-line-p)))\n\n\n(defun fsharp-statement-opens-block-p ()\n \"Return t if the current statement opens a block. For instance:\n\ntype Shape =\n | Square\n | Rectangle\n\nor:\n\nlet computation = [ this; that ]\n |> Array.someCalculation\n\nPoint should be at the start of a statement.\"\n (save-excursion\n (let ((start (point))\n (finish (progn (fsharp-goto-beyond-final-line) (1- (point))))\n (searching t)\n (answer nil)\n state)\n (goto-char start)\n ;; Keep searching until we're finished.\n (while searching\n (if (re-search-forward fsharp-block-opening-re finish t)\n (if (eq (point) finish)\n ;; sure looks like it opens a block -- but it might\n ;; be in a comment\n (progn\n (setq searching nil) ; search is done either way\n (setq state (parse-partial-sexp start\n (match-beginning 0)))\n (setq answer (not (nth 4 state)))))\n ;; search failed: couldn't find a reason to believe we're opening a block.\n (setq searching nil)))\n answer)))\n\n\n;; TODO[@gastove|2019-10-22]: the list of keywords this function claims to catch\n;; does not at all match the keywords in the regexp it wraps.\n(defun fsharp-statement-closes-block-p ()\n \"Return t iff the current statement closes a block.\nI.e., if the line starts with `return', `raise', `break', `continue',\nand `pass'. This doesn't catch embedded statements.\"\n (let ((here (point)))\n (fsharp-goto-initial-line)\n (back-to-indentation)\n (prog1\n (looking-at (concat fsharp-block-closing-keywords-re \"\\\\>\"))\n (goto-char here))))\n\n\n;;---------------------------- Electric Keystrokes ----------------------------;;\n\n(defun fsharp-electric-colon (arg)\n \"Insert a colon.\nIn certain cases the line is dedented appropriately. If a numeric\nargument ARG is provided, that many colons are inserted\nnon-electrically. Electric behavior is inhibited inside a string or\ncomment.\"\n (interactive \"*P\")\n (self-insert-command (prefix-numeric-value arg))\n ;; are we in a string or comment?\n (if (save-excursion\n (let ((pps (parse-partial-sexp (save-excursion\n (fsharp-beginning-of-def-or-class)\n (point))\n (point))))\n (not (or (nth 3 pps) (nth 4 pps)))))\n (save-excursion\n (let ((here (point))\n (outdent 0)\n (indent (fsharp-compute-indentation t)))\n (if (and (not arg)\n (fsharp-outdent-p)\n (= indent (save-excursion\n (fsharp-next-statement -1)\n (fsharp-compute-indentation t)))\n )\n (setq outdent fsharp-indent-offset))\n ;; Don't indent, only dedent. This assumes that any lines\n ;; that are already dedented relative to\n ;; fsharp-compute-indentation were put there on purpose. It's\n ;; highly annoying to have `:' indent for you. Use TAB, C-c\n ;; C-l or C-c C-r to adjust. TBD: Is there a better way to\n ;; determine this???\n (if (< (current-indentation) indent) nil\n (goto-char here)\n (beginning-of-line)\n (delete-horizontal-space)\n (indent-to (- indent outdent)))))))\n\n\n;; Electric deletion\n(defun fsharp-electric-backspace (arg)\n \"Delete preceding character or levels of indentation.\nDeletion is performed by calling the function in `fsharp-backspace-function'\nwith a single argument (the number of characters to delete).\n\nIf point is at the leftmost column, delete the preceding newline.\n\nOtherwise, if point is at the leftmost non-whitespace character of a\nline that is neither a continuation line nor a non-indenting comment\nline, or if point is at the end of a blank line, this command reduces\nthe indentation to match that of the line that opened the current\nblock of code. The line that opened the block is displayed in the\necho area to help you keep track of where you are. With\n\\\\[universal-argument] dedents that many blocks (but not past column\nzero).\n\nOtherwise the preceding character is deleted, converting a tab to\nspaces if needed so that only a single column position is deleted.\n\\\\[universal-argument] specifies how many characters to delete;\ndefault is 1.\n\nWhen used programmatically, argument ARG specifies the number of\nblocks to dedent, or the number of characters to delete, as indicated\nabove.\"\n (interactive \"*p\")\n (if (or (/= (current-indentation) (current-column))\n (bolp)\n (fsharp-continuation-line-p))\n\n (funcall fsharp-backspace-function arg)\n ;; else indent the same as the colon line that opened the block\n ;; force non-blank so fsharp-goto-block-up doesn't ignore it\n (insert-char ?* 1)\n (backward-char)\n (let ((base-indent 0) ; indentation of base line\n (base-text \"\") ; and text of base line\n (base-found-p nil))\n (save-excursion\n (while (< 0 arg)\n (condition-case nil ; in case no enclosing block\n (progn\n (fsharp-goto-block-up 'no-mark)\n (setq base-indent (current-indentation)\n base-text (fsharp-suck-up-leading-text)\n base-found-p t))\n (error nil))\n (setq arg (1- arg))))\n (delete-char 1) ; toss the dummy character\n (delete-horizontal-space)\n (indent-to base-indent)\n (if base-found-p\n (message \"Closes block: %s\" base-text)))))\n\n\n(defun fsharp-electric-delete (arg)\n \"Delete preceding or following character or levels of whitespace.\n\nThe behavior of this function depends on the variable\n`delete-key-deletes-forward'. If this variable is nil (or does not\nexist, as in older Emacsen and non-XEmacs versions), then this\nfunction behaves identically to \\\\[c-electric-backspace].\n\nIf `delete-key-deletes-forward' is non-nil and is supported in your\nEmacs, then deletion occurs in the forward direction, by calling the\nfunction in `fsharp-delete-function'.\n\n\\\\[universal-argument] (programmatically, argument ARG) specifies the\nnumber of characters to delete (default is 1).\"\n (interactive \"*p\")\n (funcall fsharp-delete-function arg))\n\n\n;; required for pending-del/delsel/delete-selection minor modes\n(put 'fsharp-electric-colon 'delete-selection t) ;delsel\n(put 'fsharp-electric-colon 'pending-delete t) ;pending-del\n(put 'fsharp-electric-backspace 'delete-selection 'supersede) ;delsel\n(put 'fsharp-electric-backspace 'pending-delete 'supersede) ;pending-del\n(put 'fsharp-electric-delete 'delete-selection 'supersede) ;delsel\n(put 'fsharp-electric-delete 'pending-delete 'supersede) ;pending-del\n\n\n;;-------------------------------- Indentation --------------------------------;;\n\n(defun fsharp-indent-line (&optional arg)\n \"Fix the indentation of the current line according to Fsharp rules.\nWith \\\\[universal-argument] (programmatically, the optional argument\nARG non-nil), ignore dedenting rules for block closing statements\n(e.g. return, raise, break, continue, pass)\n\nThis function is normally bound to `indent-line-function' so\n\\\\[indent-for-tab-command] will call it.\"\n (interactive \"P\")\n (let* ((ci (current-indentation))\n (move-to-indentation-p (<= (current-column) ci))\n (need (fsharp-compute-indentation (not arg)))\n (cc (current-column)))\n ;; dedent out a level if previous command was the same unless we're in\n ;; column 1\n (if (and (equal last-command this-command)\n (/= cc 0))\n (progn\n (beginning-of-line)\n (delete-horizontal-space)\n (indent-to (* (/ (- cc 1) fsharp-indent-offset) fsharp-indent-offset)))\n\n (progn\n ;; see if we need to dedent\n (if (fsharp-outdent-p)\n (setq need (- need fsharp-indent-offset)))\n\n (if (or fsharp-tab-always-indent\n move-to-indentation-p)\n (progn (if (/= ci need)\n (save-excursion\n (beginning-of-line)\n (delete-horizontal-space)\n (indent-to need)))\n (if move-to-indentation-p (back-to-indentation)))\n (insert-tab))))))\n\n\n;; NOTE[gastove|2019-10-25] An interesting point: this function is *only* ever\n;; called if `open-bracket-pos' is non-nil; `open-bracket-pos' is generated by\n;; `fsharp-nesting-level', which *only* returns non nil for non-string\n;; characters. And yet: we don't just rely on `open-bracket-pos' as we compute\n;; indentation, and I'm honestly not sure why.\n(defun fsharp--compute-indentation-open-bracket (open-bracket-pos)\n \"Computes indentation for a line within an open bracket expression.\"\n (save-excursion\n (let ((startpos (point))\n placeholder)\n ;; align with first item in list; else a normal\n ;; indent beyond the line with the open bracket\n (goto-char (1+ open-bracket-pos)) ; just beyond bracket\n ;; NOTE[gastove|2019-10-25] -- consider switching to a forward regexp search\n ;; with a whitepsace character class.\n ;; is the first list item on the same line?\n (skip-chars-forward \" \\t\")\n (if (and (null (memq (following-char) '(?\\n ?# ?\\\\)))\n (not fsharp-conservative-indentation-after-bracket))\n ; yes, so line up with it\n (current-column)\n ;; here follows the else\n ;; first list item on another line, or doesn't exist yet\n ;; TODO[gastove|2019-10-25] this needs to skip past whitespace, newlines,\n ;; *and* comments. I'm not convinced it does.\n (forward-line 1)\n (while (and (< (point) startpos)\n (looking-at \"[ \\t]*\\\\(//\\\\|[\\n\\\\\\\\]\\\\)\")) ; skip noise\n (forward-line 1))\n (if (and (< (point) startpos)\n (/= startpos\n (save-excursion\n (goto-char (1+ open-bracket-pos))\n (forward-comment (point-max))\n (point))))\n ;; again mimic the first list item\n (current-indentation)\n ;; else they're about to enter the first item\n\n ;; NOTE[gastove|2019-10-25] Okay, this is all really hard to follow, but\n ;; I *think* what's going on here is:\n ;; - We go to the position of the opening bracket we're trying to compute indentation against.\n ;; - We set placeholder to point (meaning we set `placeholder' to `open-bracket-pos')\n ;; - We call a function that claims to go to the first line of a statement\n ;; - We call a function that I *believe* tries to take us to the opening delimiter of a matched pair\n ;; - We return the current indentation of *that*, plus indent offset\n ;; ... holy moly.\n (goto-char open-bracket-pos)\n (setq placeholder (point))\n (fsharp-goto-initial-line)\n (fsharp-goto-beginning-of-tqs\n (save-excursion (nth 3 (parse-partial-sexp\n placeholder (point)))))\n (+ (current-indentation) fsharp-indent-offset))))))\n\n\n(defun fsharp--compute-indentation-continuation-line ()\n \"Computes the indentation for a line which continues the line\nabove, but only when the previous line is not itself a continuation line.\"\n (save-excursion\n (forward-line -11)\n (let ((startpos (point))\n (open-bracket-pos (fsharp-nesting-level))\n endpos searching found state placeholder)\n\n ;; Started on 2nd line in block, so indent more. if base line is an\n ;; assignment with a start on a RHS, indent to 2 beyond the leftmost \"=\";\n ;; else skip first chunk of non-whitespace characters on base line, + 1 more\n ;; column\n (end-of-line)\n (setq endpos (point)\n searching t)\n (back-to-indentation)\n (setq startpos (point))\n ;; look at all \"=\" from left to right, stopping at first one not nested in a\n ;; list or string\n (while searching\n (skip-chars-forward \"^=\" endpos)\n (if (= (point) endpos)\n (setq searching nil)\n (forward-char 1)\n (setq state (parse-partial-sexp startpos (point)))\n (if (and (zerop (car state)) ; not in a bracket\n (null (nth 3 state))) ; & not in a string\n (progn\n (setq searching nil) ; done searching in any case\n (setq found\n (not (or\n (eq (following-char) ?=)\n (memq (char-after (- (point) 2))\n '(?< ?> ?!)))))))))\n (if (or (not found) ; not an assignment\n (looking-at \"[ \\t]*\\\\\\\\\")) ; <=>\n (progn\n (goto-char startpos)\n (skip-chars-forward \"^ \\t\\n\")))\n ;; if this is a continuation for a block opening\n ;; statement, add some extra offset.\n (+ (current-column) (if (fsharp-statement-opens-block-p)\n fsharp-continuation-offset 0)\n 1))))\n\n\n(defun fsharp--compute-indentation-relative-to-previous (honor-block-close-p)\n \"Indentation based on that of the statement that precedes us;\nuse the first line of that statement to establish the base, in\ncase the user forced a non-std indentation for the continuation\nlines (if any)\"\n ;; skip back over blank & non-indenting comment lines note:\n ;; will skip a blank or non-indenting comment line that\n ;; happens to be a continuation line too. use fast Emacs 19\n ;; function if it's there.\n (save-excursion\n (let ((bod (fsharp-point 'bod))\n placeholder)\n (if (and (eq fsharp-honor-comment-indentation nil)\n (fboundp 'forward-comment))\n (forward-comment (- (point-max)))\n (let ((prefix-re \"//[ \\t]*\")\n done)\n (while (not done)\n (re-search-backward \"^[ \\t]*\\\\([^ \\t\\n]\\\\|//\\\\)\" nil 'move)\n (setq done (or (bobp)\n (and (eq fsharp-honor-comment-indentation t)\n (save-excursion\n (back-to-indentation)\n (not (looking-at prefix-re))\n ))\n (and (not (eq fsharp-honor-comment-indentation t))\n (save-excursion\n (back-to-indentation)\n (and (not (looking-at prefix-re))\n (or (looking-at \"[^/]\")\n (not (zerop (current-column))))))))))))\n ;; if we landed inside a string, go to the beginning of that\n ;; string. this handles triple quoted, multi-line spanning\n ;; strings.\n (fsharp-goto-beginning-of-tqs (nth 3 (parse-partial-sexp bod (point))))\n ;; now skip backward over continued lines\n (setq placeholder (point))\n (fsharp-goto-initial-line)\n ;; we may *now* have landed in a TQS, so find the beginning of\n ;; this string.\n (fsharp-goto-beginning-of-tqs\n (save-excursion (nth 3 (parse-partial-sexp\n placeholder (point)))))\n (+ (current-indentation)\n (if (fsharp-statement-opens-block-p)\n fsharp-indent-offset\n (if (and honor-block-close-p (fsharp-statement-closes-block-p))\n (- fsharp-indent-offset)\n 0))))))\n\n\n(defun fsharp-newline-and-indent ()\n \"Strives to act like the Emacs `newline-and-indent'.\nThis is just `strives to' because correct indentation can't be computed\nfrom scratch for Fsharp code. In general, deletes the whitespace before\npoint, inserts a newline, and takes an educated guess as to how you want\nthe new line indented.\"\n (interactive)\n (let ((ci (current-indentation)))\n (if (< ci (current-column)) ; if point beyond indentation\n (newline-and-indent)\n ;; else try to act like newline-and-indent \"normally\" acts\n (beginning-of-line)\n (insert-char ?\\n 1)\n (move-to-column ci))))\n\n\n(defun fsharp-compute-indentation (honor-block-close-p)\n \"Compute Fsharp indentation.\nWhen HONOR-BLOCK-CLOSE-P is non-nil, statements such as `return',\n`raise', `break', `continue', and `pass' force one level of\ndedenting.\"\n (save-excursion\n (beginning-of-line)\n (let* ((bod (fsharp-point 'bod))\n (pps (parse-partial-sexp bod (point)))\n (boipps (parse-partial-sexp bod (fsharp-point 'boi)))\n (open-bracket-pos (fsharp-nesting-level)))\n\n (cond\n ((and open-bracket-pos (eq (and (looking-back \"[[:space:]\\n\\r]+\" nil t)\n\t\t\t\t (match-beginning 0))\n\t\t\t\t (1+ open-bracket-pos)))\n\tfsharp-indent-offset)\n ;; Continuation Lines\n ((fsharp-continuation-line-p)\n (if open-bracket-pos\n (fsharp--compute-indentation-open-bracket open-bracket-pos)\n (fsharp--compute-indentation-continuation-line)))\n\n ;; Previous line is a continuation line, use indentation of previous line\n ((fsharp--previous-line-continuation-line-p)\n (forward-line -1)\n (current-indentation))\n\n ((or\n ;; Beginning of Buffer; not on a continuation line\n (bobp)\n ;; \"Indenting Comment\"\n (fsharp--indenting-comment-p)) (current-indentation))\n\n ;; Final case includes things like pipe expressions (matches, left pipe)\n ;; and if/else blocks.\n ;;\n ;; else indentation based on that of the statement that\n ;; precedes us; use the first line of that statement to\n ;; establish the base, in case the user forced a non-std\n ;; indentation for the continuation lines (if any)\n (t (fsharp--compute-indentation-relative-to-previous honor-block-close-p))))))\n\n(defun fsharp-guess-indent-offset (&optional global)\n \"Guess a good value for, and change, `fsharp-indent-offset'.\n\nBy default, make a buffer-local copy of `fsharp-indent-offset' with the\nnew value, so that other Fsharp buffers are not affected. With\n\\\\[universal-argument] (programmatically, optional argument GLOBAL),\nchange the global value of `fsharp-indent-offset'. This affects all\nFsharp buffers (that don't have their own buffer-local copy), both\nthose currently existing and those created later in the Emacs session.\n\nSome people use a different value for `fsharp-indent-offset' than you use.\nThere's no excuse for such foolishness, but sometimes you have to deal\nwith their ugly code anyway. This function examines the file and sets\n`fsharp-indent-offset' to what it thinks it was when they created the\nmess.\n\nSpecifically, it searches forward from the statement containing point,\nlooking for a line that opens a block of code. `fsharp-indent-offset' is\nset to the difference in indentation between that line and the Fsharp\nstatement following it. If the search doesn't succeed going forward,\nit's tried again going backward.\"\n (interactive \"P\") ; raw prefix arg\n (let (new-value\n (start (point))\n (restart (point))\n (found nil)\n colon-indent)\n (fsharp-goto-initial-line)\n (while (not (or found (eobp)))\n (when (and (re-search-forward fsharp-block-opening-re nil 'move)\n (not (fsharp-in-literal-p restart)))\n (setq restart (point))\n (fsharp-goto-initial-line)\n (if (fsharp-statement-opens-block-p)\n (setq found t)\n (goto-char restart))))\n (unless found\n (goto-char start)\n (fsharp-goto-initial-line)\n (while (not (or found (bobp)))\n (setq found (and\n (re-search-backward fsharp-block-opening-re nil 'move)\n (or (fsharp-goto-initial-line) t) ; always true -- side effect\n (fsharp-statement-opens-block-p)))))\n (setq colon-indent (current-indentation)\n found (and found (zerop (fsharp-next-statement 1)))\n new-value (- (current-indentation) colon-indent))\n (goto-char start)\n (if (not found)\n (message \"Unable to determine default value for fsharp-indent-offset\")\n (funcall (if global 'kill-local-variable 'make-local-variable)\n 'fsharp-indent-offset)\n (setq fsharp-indent-offset new-value)\n (or noninteractive\n (message \"%s value of fsharp-indent-offset set to %d\"\n (if global \"Global\" \"Local\")\n fsharp-indent-offset)))))\n\n(defun fsharp-comment-indent-function ()\n \"Fsharp version of `comment-indent-function'.\"\n ;; This is required when filladapt is turned off. Without it, when\n ;; filladapt is not used, comments which start in column zero\n ;; cascade one character to the right\n (save-excursion\n (beginning-of-line)\n (let ((eol (fsharp-point 'eol)))\n (and comment-start-skip\n (re-search-forward comment-start-skip eol t)\n (setq eol (match-beginning 0)))\n (goto-char eol)\n (skip-chars-backward \" \\t\")\n (max comment-column (+ (current-column) (if (bolp) 0 1))))))\n\n(defun fsharp-narrow-to-defun (&optional class)\n \"Make text outside current defun invisible.\nThe defun visible is the one that contains point or follows point.\nOptional CLASS is passed directly to `fsharp-beginning-of-def-or-class'.\"\n (interactive \"P\")\n (save-excursion\n (widen)\n (fsharp-end-of-def-or-class class)\n (let ((end (point)))\n (fsharp-beginning-of-def-or-class class)\n (narrow-to-region (point) end))))\n\n\f\n(defun fsharp-shift-region (start end count)\n \"Indent lines from START to END by COUNT spaces.\"\n (save-excursion\n (goto-char end)\n (beginning-of-line)\n (setq end (point))\n (goto-char start)\n (beginning-of-line)\n (setq start (point))\n (indent-rigidly start end count)))\n\n(defun fsharp-shift-region-left (start end &optional count)\n \"Shift region of Fsharp code to the left.\nThe lines from the line containing the start of the current region up\nto (but not including) the line containing the end of the region are\nshifted to the left, by `fsharp-indent-offset' columns.\n\nIf a prefix argument is given, the region is instead shifted by that\nmany columns. With no active region, dedent only the current line.\nYou cannot dedent the region if any line is already at column zero.\"\n (interactive\n (let ((p (point))\n (m (mark))\n (arg current-prefix-arg))\n (if m\n (list (min p m) (max p m) arg)\n (list p (save-excursion (forward-line 1) (point)) arg))))\n ;; if any line is at column zero, don't shift the region\n (save-excursion\n (goto-char start)\n (while (< (point) end)\n (back-to-indentation)\n (if (and (zerop (current-column))\n (not (looking-at \"\\\\s *$\")))\n (error \"Region is at left edge\"))\n (forward-line 1)))\n (fsharp-shift-region start end (- (prefix-numeric-value\n (or count fsharp-indent-offset)))))\n\n\n(defun fsharp-shift-region-right (start end &optional count)\n \"Shift region of Fsharp code to the right.\nThe lines from the line containing the start of the current region up\nto (but not including) the line containing the end of the region are\nshifted to the right, by `fsharp-indent-offset' columns.\n\nIf a prefix argument is given, the region is instead shifted by that\nmany columns. With no active region, indent only the current line.\"\n (interactive\n (let ((p (point))\n (m (mark))\n (arg current-prefix-arg))\n (if m\n (list (min p m) (max p m) arg)\n (list p (save-excursion (forward-line 1) (point)) arg))))\n (fsharp-shift-region start end (prefix-numeric-value\n (or count fsharp-indent-offset))))\n\n\n(defun fsharp-indent-region (start end &optional indent-offset)\n \"Reindent a region of Fsharp code.\n\nThe lines from the line containing the start of the current region up\nto (but not including) the line containing the end of the region are\nreindented. If the first line of the region has a non-whitespace\ncharacter in the first column, the first line is left alone and the\nrest of the region is reindented with respect to it. Else the entire\nregion is reindented with respect to the (closest code or indenting\ncomment) statement immediately preceding the region.\n\nThis is useful when code blocks are moved or yanked, when enclosing\ncontrol structures are introduced or removed, or to reformat code\nusing a new value for the indentation offset.\n\nIf a numeric prefix argument is given, it will be used as the value of\nthe indentation offset. Else the value of `fsharp-indent-offset' will be\nused.\n\nWarning: The region must be consistently indented before this function\nis called! This function does not compute proper indentation from\nscratch (that's impossible in Fsharp), it merely adjusts the existing\nindentation to be correct in context.\n\nWarning: This function really has no idea what to do with\nnon-indenting comment lines, and shifts them as if they were indenting\ncomment lines. Fixing this appears to require telepathy.\n\nSpecial cases: whitespace is deleted from blank lines; continuation\nlines are shifted by the same amount their initial line was shifted,\nin order to preserve their relative indentation with respect to their\ninitial line; and comment lines beginning in column 1 are ignored.\"\n (interactive \"*r\\nP\") ; region; raw prefix arg\n (save-excursion\n (goto-char end) (beginning-of-line) (setq end (point-marker))\n (goto-char start) (beginning-of-line)\n (let ((fsharp-indent-offset (prefix-numeric-value\n (or indent-offset fsharp-indent-offset)))\n (indents '(-1)) ; stack of active indent levels\n (target-column 0) ; column to which to indent\n (base-shifted-by 0) ; amount last base line was shifted\n (indent-base (if (looking-at \"[ \\t\\n]\")\n (fsharp-compute-indentation t)\n 0))\n ci)\n (while (< (point) end)\n (setq ci (current-indentation))\n ;; figure out appropriate target column\n (cond\n ((or (looking-at \"//\") ; comment in column 1\n (looking-at \"[ \\t]*$\")) ; entirely blank\n (setq target-column 0))\n ((fsharp-continuation-line-p) ; shift relative to base line\n (setq target-column (+ ci base-shifted-by)))\n (t ; new base line\n (if (> ci (car indents)) ; going deeper; push it\n (setq indents (cons ci indents))\n ;; else we should have seen this indent before\n (setq indents (memq ci indents)) ; pop deeper indents\n (if (null indents)\n (error \"Bad indentation in region, at line %d\"\n (save-restriction\n (widen)\n (1+ (count-lines 1 (point)))))))\n (setq target-column (+ indent-base\n (* fsharp-indent-offset\n (- (length indents) 2))))\n (setq base-shifted-by (- target-column ci))))\n ;; shift as needed\n (if (/= ci target-column)\n (progn\n (delete-horizontal-space)\n (indent-to target-column)))\n (forward-line 1))))\n (set-marker end nil))\n\n\n;;------------------------------ Motion and Mark ------------------------------;;\n\n(defun fsharp-previous-statement (count)\n \"Go to the start of the COUNTth preceding Fsharp statement.\nBy default, goes to the previous statement. If there is no such\nstatement, goes to the first statement. Return count of statements\nleft to move. `Statements' do not include blank, comment, or\ncontinuation lines.\"\n (interactive \"p\") ; numeric prefix arg\n (if (< count 0) (fsharp-next-statement (- count))\n (fsharp-goto-initial-line)\n (let (start)\n (while (and\n (setq start (point)) ; always true -- side effect\n (> count 0)\n (zerop (forward-line -1))\n (fsharp-goto-statement-at-or-above))\n (setq count (1- count)))\n (if (> count 0) (goto-char start)))\n count))\n\n(defun fsharp-next-statement (count)\n \"Go to the start of next Fsharp statement.\nIf the statement at point is the i'th Fsharp statement, goes to the\nstart of statement i+COUNT. If there is no such statement, goes to the\nlast statement. Returns count of statements left to move. `Statements'\ndo not include blank, comment, or continuation lines.\"\n (interactive \"p\") ; numeric prefix arg\n (if (< count 0) (fsharp-previous-statement (- count))\n (beginning-of-line)\n (let (start)\n (while (and\n (setq start (point)) ; always true -- side effect\n (> count 0)\n (fsharp-goto-statement-below))\n (setq count (1- count)))\n (if (> count 0) (goto-char start)))\n count))\n\n(defun fsharp-goto-block-up (&optional nomark)\n \"Move up to start of current block.\nGo to the statement that starts the smallest enclosing block; roughly\nspeaking, this will be the closest preceding statement that ends with a\ncolon and is indented less than the statement you started on. If\nsuccessful, also sets the mark to the starting point.\n\n`\\\\[fsharp-mark-block]' can be used afterward to mark the whole code\nblock, if desired.\n\nIf called from a program, the mark will not be set if optional argument\nNOMARK is not nil.\"\n (interactive)\n (let ((start (point))\n (found nil)\n initial-indent)\n (fsharp-goto-initial-line)\n ;; if on and (mutually recursive bindings), blank or non-indenting comment line, use the preceding stmt\n (when (or (looking-at \"[ \\t]*\\\\($\\\\|//[^ \\t\\n]\\\\)\")\n (looking-at-p \"[ \\t]*and[ \\t]+\"))\n (fsharp-goto-statement-at-or-above)\n (setq found (fsharp-statement-opens-block-p)))\n ;; search back for colon line indented less\n (setq initial-indent (current-indentation))\n (if (zerop initial-indent)\n ;; force fast exit\n (goto-char (point-min)))\n (while (not (or found (bobp)))\n (setq found\n (and\n (re-search-backward fsharp-block-opening-re nil 'move)\n (or (fsharp-goto-initial-line) t) ; always true -- side effect\n (< (current-indentation) initial-indent)\n (fsharp-statement-opens-block-p))))\n (if found\n (progn\n (or nomark (push-mark start))\n (back-to-indentation))\n (goto-char start)\n (error \"Enclosing block not found\"))))\n\n;; The FIXME comment here is antique, and unexplained. My suspicion is that this\n;; function was lifted from a Python mode (F# doesn't have the `def' keyword).\n;; -- RMD 2019-10-20\n;;FIXME\n(defun fsharp-beginning-of-def-or-class (&optional class count)\n \"Move point to start of `def' or `class'.\n\nSearches back for the closest preceding `def'. If you supply a prefix\narg, looks for a `class' instead. The docs below assume the `def'\ncase; just substitute `class' for `def' for the other case.\nProgrammatically, if CLASS is `either', then moves to either `class'\nor `def'.\n\nWhen second optional argument is given programmatically, move to the\nCOUNTth start of `def'.\n\nIf point is in a `def' statement already, and after the `d', simply\nmoves point to the start of the statement.\n\nOtherwise (i.e. when point is not in a `def' statement, or at or\nbefore the `d' of a `def' statement), searches for the closest\npreceding `def' statement, and leaves point at its start. If no such\nstatement can be found, leaves point at the start of the buffer.\n\nReturns t iff a `def' statement is found by these rules.\n\nNote that doing this command repeatedly will take you closer to the\nstart of the buffer each time.\n\nTo mark the current `def', see `\\\\[fsharp-mark-def-or-class]'.\"\n (interactive \"P\") ; raw prefix arg\n (setq count (or count 1))\n (let ((at-or-before-p (<= (current-column) (current-indentation)))\n (start-of-line (goto-char (fsharp-point 'bol)))\n (start-of-stmt (goto-char (fsharp-point 'bos)))\n (start-re (cond ((eq class 'either) \"^[ \\t]*\\\\(type\\\\|let\\\\)\\\\>\")\n (class \"^[ \\t]*type\\\\>\")\n (t \"^[ \\t]*let\\\\>\"))))\n ;; searching backward\n (if (and (< 0 count)\n (or (/= start-of-stmt start-of-line)\n (not at-or-before-p)))\n (end-of-line))\n ;; search forward\n (if (and (> 0 count)\n (zerop (current-column))\n (looking-at start-re))\n (end-of-line))\n (if (re-search-backward start-re nil 'move count)\n (goto-char (match-beginning 0)))))\n\n;; Backwards compatibility\n(defalias 'beginning-of-fsharp-def-or-class 'fsharp-beginning-of-def-or-class)\n\n(defun fsharp-end-of-def-or-class (&optional class count)\n \"Move point beyond end of `def' or `class' body.\n\nBy default, looks for an appropriate `def'. If you supply a prefix\narg, looks for a `class' instead. The docs below assume the `def'\ncase; just substitute `class' for `def' for the other case.\nProgrammatically, if CLASS is `either', then moves to either `class'\nor `def'.\n\nWhen second optional argument is given programmatically, move to the\nCOUNTth end of `def'.\n\nIf point is in a `def' statement already, this is the `def' we use.\n\nElse, if the `def' found by `\\\\[fsharp-beginning-of-def-or-class]'\ncontains the statement you started on, that's the `def' we use.\n\nOtherwise, we search forward for the closest following `def', and use that.\n\nIf a `def' can be found by these rules, point is moved to the start of\nthe line immediately following the `def' block, and the position of the\nstart of the `def' is returned.\n\nElse point is moved to the end of the buffer, and nil is returned.\n\nNote that doing this command repeatedly will take you closer to the\nend of the buffer each time.\n\nTo mark the current `def', see `\\\\[fsharp-mark-def-or-class]'.\"\n (interactive \"P\") ; raw prefix arg\n (if (and count (/= count 1))\n (fsharp-beginning-of-def-or-class (- 1 count)))\n (let ((start (progn (fsharp-goto-initial-line) (point)))\n (which (cond ((eq class 'either) \"\\\\(type\\\\|let\\\\)\")\n (class \"type\")\n (t \"let\")))\n (state 'not-found))\n ;; move point to start of appropriate def/class\n (if (looking-at (concat \"[ \\t]*\" which \"\\\\>\")) ; already on one\n (setq state 'at-beginning)\n ;; else see if fsharp-beginning-of-def-or-class hits container\n (if (and (fsharp-beginning-of-def-or-class class)\n (progn (fsharp-goto-beyond-block)\n (> (point) start)))\n (setq state 'at-end)\n ;; else search forward\n (goto-char start)\n (if (re-search-forward (concat \"^[ \\t]*\" which \"\\\\>\") nil 'move)\n (progn (setq state 'at-beginning)\n (beginning-of-line)))))\n (cond\n ((eq state 'at-beginning) (fsharp-goto-beyond-block) t)\n ((eq state 'at-end) t)\n ((eq state 'not-found) nil)\n (t (error \"Internal error in `fsharp-end-of-def-or-class'\")))))\n\n\n;; Helper functions\n\n\n;; TODO: we only return the parse state if we are *not* inside a string. This\n;; doesn't make a lot of sense; checking for being inside a triple-quoted string\n;; is a thing we frequently need to do. Need to figure out a reason and/or\n;; abstract over the top of this.\n(defun fsharp-parse-state ()\n \"Return the parse state at point (see `parse-partial-sexp' docs).\"\n (save-excursion\n (let ((here (point))\n pps done)\n (while (not done)\n ;; back up to the first preceding line (if any; else start of\n ;; buffer) that begins with a popular Fsharp keyword, or a\n ;; non- whitespace and non-comment character. These are good\n ;; places to start parsing to see whether where we started is\n ;; at a non-zero nesting level. It may be slow for people who\n ;; write huge code blocks or huge lists ... tough beans.\n (re-search-backward fsharp-parse-state-re nil 'move)\n (beginning-of-line)\n ;; In XEmacs, we have a much better way to test for whether\n ;; we're in a triple-quoted string or not. Emacs does not\n ;; have this built-in function, which is its loss because\n ;; without scanning from the beginning of the buffer, there's\n ;; no accurate way to determine this otherwise.\n ;;\n ;; NOTE[@gastove|2019-10-21]: it is not at *all* clear what this comment is on\n ;; about. Emacs has all the functions used in this function.\n (save-excursion (setq pps (parse-partial-sexp (point) here)))\n ;; make sure we don't land inside a triple-quoted string\n (setq done (or (not (nth 3 pps))\n (bobp)))\n ;; Just go ahead and short circuit the test back to the\n ;; beginning of the buffer. This will be slow, but not\n ;; nearly as slow as looping through many\n ;; re-search-backwards.\n (if (not done)\n (goto-char (point-min))))\n pps)))\n\n(defun fsharp-nesting-level ()\n \"Return the buffer position of the opening character of the\ncurrent enclosing pair. If nesting level is zero, return nil.\n\nAt time of writing, enclosing pair can be [], {} or (), but not\nquotes (single or triple) or <>. Note that registering []\nimplicitly also registers [||], though the pipes are ignored.\"\n (let ((status (fsharp-parse-state)))\n (if (zerop (car status))\n nil ; not in a nest\n (car (cdr status))))) ; char of open bracket\n\n\n;; NOTE[gastove|2019-10-25] this function baffles me. A triple-quoted string is,\n;; definitionally, always delimited by *triple quotes*. I suspect this function\n;; of being something more akin to, \"go to beginning of opening of pair\", or\n;; just \"go to delimiter.\"\n(defun fsharp-goto-beginning-of-tqs (delim)\n \"Go to the beginning of the triple quoted string we find ourselves in.\nDELIM is the TQS string delimiter character we're searching backwards\nfor.\"\n (let ((skip (and delim (make-string 1 delim)))\n (continue t))\n (when skip\n (save-excursion\n (while continue\n (search-backward skip nil t)\n (setq continue (and (not (bobp))\n (= (char-before) ?\\\\))))\n (if (and (= (char-before) delim)\n (= (char-before (1- (point))) delim))\n (setq skip (make-string 3 delim))))\n ;; we're looking at a triple-quoted string\n (search-backward skip nil t))))\n\n\n(defun fsharp-goto-initial-line ()\n \"Go to the initial line of the current statement.\nUsually this is the line we're on, but if we're on the 2nd or\nfollowing lines of a continuation block, we need to go up to the first\nline of the block.\"\n ;; Tricky: We want to avoid quadratic-time behavior for long\n ;; continued blocks, whether of the backslash or open-bracket\n ;; varieties, or a mix of the two. The following manages to do that\n ;; in the usual cases.\n ;;\n ;; Also, if we're sitting inside a triple quoted string, this will\n ;; drop us at the line that begins the string.\n (let (open-bracket-pos)\n (while (fsharp-continuation-line-p)\n (beginning-of-line)\n (if (fsharp--hanging-operator-continuation-line-p)\n (while (fsharp--hanging-operator-continuation-line-p)\n (forward-line -1))\n ;; else zip out of nested brackets/braces/parens\n (while (setq open-bracket-pos (fsharp-nesting-level))\n (goto-char open-bracket-pos)))))\n (beginning-of-line))\n\n;; TODO[gastove|2019-10-31] This is completely broken. I'm not totally sure why\n;; or how, but it simply doesn't do the thing it says on the tin.\n(defun fsharp-goto-beyond-final-line ()\n \"Go to the point just beyond the final line of the current expression.\nUsually this is the start of the next line, but if this is a\nmulti-line expression we need to skip over the continuation\nlines.\"\n ;; TODO[gastove|2019-10-30] This works on triple-quoted strings that start on\n ;; their own line, but not if they are opened on the same line as a let.\n (if (looking-at (concat \"[ \\t]*\\\\(\" fsharp-stringlit-re \"\\\\)\"))\n (goto-char (match-end 0)))\n ;;\n (forward-line 1)\n (let (state)\n ;; I think this first predicate is the problem -- \"continuation lines\", as\n ;; defined by that function, are only lines with hanging arithmetic\n ;; operators *or* lines inside certain pairs (things like data structures\n ;; and computation expressions). This fully doesn't account for\n ;; continuations using pipes.\n (while (and (fsharp-continuation-line-p)\n (not (eobp)))\n ;; skip over hanging operator lines\n (while (and (fsharp--hanging-operator-continuation-line-p)\n (not (eobp)))\n (forward-line 1))\n ;; if in nest, zip to the end of the nest\n (setq state (fsharp-parse-state))\n (when (and (not (zerop (car state)))\n (not (eobp)))\n (progn\n (parse-partial-sexp (point) (point-max) 0 nil state)\n (forward-line 1))))))\n\n\n(defun fsharp-goto-beyond-block ()\n \"Go to point just beyond the final line of block begun by the current line.\nThis is the same as where `fsharp-goto-beyond-final-line' goes unless\nwe're on colon line, in which case we go to the end of the block.\nAssumes point is at the beginning of the line.\"\n (if (fsharp-statement-opens-block-p)\n (fsharp-mark-block nil 'just-move)\n (fsharp-goto-beyond-final-line)))\n\n\n(defun fsharp-goto-statement-at-or-above ()\n \"Go to the start of the first statement at or preceding point.\nReturn t if there is such a statement, otherwise nil. `Statement'\ndoes not include blank lines, comments, or continuation lines.\"\n (fsharp-goto-initial-line)\n (if (looking-at fsharp-blank-or-comment-re)\n ;; skip back over blank & comment lines\n ;; note: will skip a blank or comment line that happens to be\n ;; a continuation line too\n (if (re-search-backward \"^[ \\t]*\\\\([^ \\t\\n]\\\\|//\\\\)\" nil t)\n (progn (fsharp-goto-initial-line) t)\n nil)\n t))\n\n(defun fsharp-goto-statement-below ()\n \"Go to start of the first statement following the statement containing point.\nReturn t if there is such a statement, otherwise nil. `Statement'\ndoes not include blank lines, comments, or continuation lines.\"\n (beginning-of-line)\n (let ((start (point)))\n (fsharp-goto-beyond-final-line)\n (while (and\n (or (looking-at fsharp-blank-or-comment-re)\n (fsharp-in-literal-p))\n (not (eobp)))\n (forward-line 1))\n (if (eobp)\n (progn (goto-char start) nil)\n t)))\n\n(defun fsharp-go-up-tree-to-keyword (key)\n \"Go to begining of statement starting with KEY, at or preceding point.\n\nKEY is a regular expression describing a Fsharp keyword. Skip blank\nlines and non-indenting comments. If the statement found starts with\nKEY, then stop, otherwise go back to first enclosing block starting\nwith KEY. If successful, leave point at the start of the KEY line and\nreturn t. Otherwise, leave point at an undefined place and return nil.\"\n ;; skip blanks and non-indenting //\n (fsharp-goto-initial-line)\n (while (and\n (looking-at \"[ \\t]*\\\\($\\\\|//[^ \\t\\n]\\\\)\")\n (zerop (forward-line -1))) ; go back\n nil)\n (fsharp-goto-initial-line)\n (let* ((re (concat \"[ \\t]*\" key \"\\\\>\"))\n (case-fold-search nil) ; let* so looking-at sees this\n (found (looking-at re))\n (dead nil))\n (while (not (or found dead))\n (condition-case nil ; in case no enclosing block\n (fsharp-goto-block-up 'no-mark)\n (error (setq dead t)))\n (or dead (setq found (looking-at re))))\n (beginning-of-line)\n found))\n\n\n(defun fsharp-suck-up-leading-text ()\n \"Return string in buffer from start of indentation to end of line.\nPrefix with \\\"...\\\" if leading whitespace was skipped.\"\n (save-excursion\n (back-to-indentation)\n (concat\n (if (bolp) \"\" \"...\")\n (buffer-substring (point) (progn (end-of-line) (point))))))\n\n\n(defun fsharp-suck-up-first-keyword ()\n \"Return first keyword on the line as a Lisp symbol.\n`Keyword' is defined (essentially) as the regular expression\n([a-z]+). Returns nil if none was found.\"\n (let ((case-fold-search nil))\n (if (looking-at \"[ \\t]*\\\\([a-z]+\\\\)\\\\>\")\n (intern (buffer-substring (match-beginning 1) (match-end 1)))\n nil)))\n\n(defun fsharp-current-defun ()\n \"Fsharp value for `add-log-current-defun-function'.\nThis tells add-log.el how to find the current function/method/variable.\"\n (save-excursion\n\n ;; Move back to start of the current statement.\n\n (fsharp-goto-initial-line)\n (back-to-indentation)\n (while (and (or (looking-at fsharp-blank-or-comment-re)\n (fsharp-in-literal-p))\n (not (eq (point-at-bol) (point-min))))\n (backward-to-indentation 1))\n (fsharp-goto-initial-line)\n\n (let ((scopes \"\")\n (sep \"\")\n dead assignment)\n\n ;; Check for an assignment. If this assignment exists inside a\n ;; def, it will be overwritten inside the while loop. If it\n ;; exists at top lever or inside a class, it will be preserved.\n\n (when (looking-at \"[ \\t]*\\\\([a-zA-Z0-9_]+\\\\)[ \\t]*=\")\n (setq scopes (buffer-substring (match-beginning 1) (match-end 1)))\n (setq assignment t)\n (setq sep \".\"))\n\n ;; Prepend the name of each outer socpe (def or class).\n\n (while (not dead)\n (if (and (fsharp-go-up-tree-to-keyword \"\\\\(class\\\\|def\\\\)\")\n (looking-at\n \"[ \\t]*\\\\(class\\\\|def\\\\)[ \\t]*\\\\([a-zA-Z0-9_]+\\\\)[ \\t]*\"))\n (let ((name (buffer-substring (match-beginning 2) (match-end 2))))\n (if (and assignment (looking-at \"[ \\t]*def\"))\n (setq scopes name)\n (setq scopes (concat name sep scopes))\n (setq sep \".\"))))\n (setq assignment nil)\n (condition-case nil ; Terminate nicely at top level.\n (fsharp-goto-block-up 'no-mark)\n (error (setq dead t))))\n (if (string= scopes \"\")\n nil\n scopes))))\n\n\n(defun fsharp-beginning-of-block ()\n \"Move point to the beginning of the current top-level block\"\n (interactive)\n (let ((prev (point)))\n (condition-case nil\n (while (progn (fsharp-goto-block-up 'no-mark)\n (< (point) prev))\n (setq prev (point)))\n (error (while (fsharp-continuation-line-p)\n (forward-line -1)))))\n (beginning-of-line))\n\n\n(defun fsharp-end-of-block ()\n \"Move point to the end of the current top-level block\"\n (interactive)\n (forward-line 1)\n (if (not (eobp))\n (progn\n (beginning-of-line)\n (condition-case nil\n (progn (re-search-forward \"^[a-zA-Z#0-9([]\")\n (while (fsharp-continuation-line-p)\n (forward-line 1))\n (forward-line -1))\n (error\n (progn (goto-char (point-max)))))\n (end-of-line)\n (when (looking-at-p \"\\n[ \\t]*and[ \\t]+\")\n (forward-line 1)\n (fsharp-end-of-block)))\n (goto-char (point-max))))\n\n\n(defun fsharp-mark-phrase ()\n \"Mark current phrase\"\n (interactive)\n (fsharp-beginning-of-block)\n (push-mark (point))\n (fsharp-end-of-block)\n (exchange-point-and-mark))\n\n\n(defun fsharp-mark-block (&optional extend just-move)\n \"Mark following block of lines. With prefix arg, mark structure.\nEasier to use than explain. It sets the region to an `interesting'\nblock of succeeding lines. If point is on a blank line, it goes down to\nthe next non-blank line. That will be the start of the region. The end\nof the region depends on the kind of line at the start:\n\n - If a comment, the region will include all succeeding comment lines up\n to (but not including) the next non-comment line (if any).\n\n - Else if a prefix arg is given, and the line begins one of these\n structures:\n\n if elif else try except finally for while def class\n\n the region will be set to the body of the structure, including\n following blocks that `belong' to it, but excluding trailing blank\n and comment lines. E.g., if on a `try' statement, the `try' block\n and all (if any) of the following `except' and `finally' blocks\n that belong to the `try' structure will be in the region. Ditto\n for if/elif/else, for/else and while/else structures, and (a bit\n degenerate, since they're always one-block structures) def and\n class blocks.\n\n - Else if no prefix argument is given, and the line begins a Fsharp\n block (see list above), and the block is not a `one-liner' (i.e.,\n the statement ends with a colon, not with code), the region will\n include all succeeding lines up to (but not including) the next\n code statement (if any) that's indented no more than the starting\n line, except that trailing blank and comment lines are excluded.\n E.g., if the starting line begins a multi-statement `def'\n structure, the region will be set to the full function definition,\n but without any trailing `noise' lines.\n\n - Else the region will include all succeeding lines up to (but not\n including) the next blank line, or code or indenting-comment line\n indented strictly less than the starting line. Trailing indenting\n comment lines are included in this case, but not trailing blank\n lines.\n\nA msg identifying the location of the mark is displayed in the echo\narea; or do `\\\\[exchange-point-and-mark]' to flip down to the end.\n\nIf called from a program, optional argument EXTEND plays the role of\nthe prefix arg, and if optional argument JUST-MOVE is not nil, just\nmoves to the end of the block (& does not set mark or display a msg).\"\n (interactive \"P\") ; raw prefix arg\n (fsharp-goto-initial-line)\n ;; skip over blank lines\n (while (and\n (looking-at \"[ \\t]*$\") ; while blank line\n (not (eobp))) ; & somewhere to go\n (forward-line 1))\n (if (eobp)\n (error \"Hit end of buffer without finding a non-blank stmt\"))\n (let ((initial-pos (point))\n (initial-indent (current-indentation))\n last-pos ; position of last stmt in region\n (followers\n '((if elif else) (elif elif else) (else)\n (try except finally) (except except) (finally)\n (for else) (while else)\n (def) (class) ) )\n first-symbol next-symbol)\n\n (cond\n ;; if comment line, suck up the following comment lines\n ((looking-at \"[ \\t]*//\")\n (re-search-forward \"^[ \\t]*\\\\([^ \\t]\\\\|//\\\\)\" nil 'move) ; look for non-comment\n (re-search-backward \"^[ \\t]*//\") ; and back to last comment in block\n (setq last-pos (point)))\n\n ;; else if line is a block line and EXTEND given, suck up\n ;; the whole structure\n ((and extend\n (setq first-symbol (fsharp-suck-up-first-keyword) )\n (assq first-symbol followers))\n (while (and\n (or (fsharp-goto-beyond-block) t) ; side effect\n (forward-line -1) ; side effect\n (setq last-pos (point)) ; side effect\n (fsharp-goto-statement-below)\n (= (current-indentation) initial-indent)\n (setq next-symbol (fsharp-suck-up-first-keyword))\n (memq next-symbol (cdr (assq first-symbol followers))))\n (setq first-symbol next-symbol)))\n\n ;; else if line *opens* a block, search for next stmt indented <=\n ((fsharp-statement-opens-block-p)\n (while (and\n (setq last-pos (point)) ; always true -- side effect\n (fsharp-goto-statement-below)\n (> (current-indentation) initial-indent))))\n\n ;; else plain code line; stop at next blank line, or stmt or\n ;; indenting comment line indented <\n (t\n (while (and\n (setq last-pos (point)) ; always true -- side effect\n (or (fsharp-goto-beyond-final-line) t)\n (not (looking-at \"[ \\t]*$\")) ; stop at blank line\n (or\n (>= (current-indentation) initial-indent)\n (looking-at \"[ \\t]*//[^ \\t\\n]\"))) ; ignore non-indenting //\n nil)))\n\n ;; skip to end of last stmt\n (goto-char last-pos)\n (fsharp-goto-beyond-final-line)\n\n ;; set mark & display\n (if just-move\n () ; just return\n (push-mark (point) 'no-msg)\n (forward-line -1)\n (message \"Mark set after: %s\" (fsharp-suck-up-leading-text))\n (goto-char initial-pos))))\n\n(defun fsharp-mark-def-or-class (&optional class)\n \"Set region to body of def (or class, with prefix arg) enclosing point.\nPushes the current mark, then point, on the mark ring (all language\nmodes do this, but although it's handy it's never documented ...).\n\nIn most Emacs language modes, this function bears at least a\nhallucinogenic resemblance to `\\\\[fsharp-end-of-def-or-class]' and\n`\\\\[fsharp-beginning-of-def-or-class]'.\n\nAnd in earlier versions of Fsharp mode, all 3 were tightly connected.\nTurned out that was more confusing than useful: the `goto start' and\n`goto end' commands are usually used to search through a file, and\npeople expect them to act a lot like `search backward' and `search\nforward' string-search commands. But because Fsharp `def' and `class'\ncan nest to arbitrary levels, finding the smallest def containing\npoint cannot be done via a simple backward search: the def containing\npoint may not be the closest preceding def, or even the closest\npreceding def that's indented less. The fancy algorithm required is\nappropriate for the usual uses of this `mark' command, but not for the\n`goto' variations.\n\nSo the def marked by this command may not be the one either of the\n`goto' commands find: If point is on a blank or non-indenting comment\nline, moves back to start of the closest preceding code statement or\nindenting comment line. If this is a `def' statement, that's the def\nwe use. Else searches for the smallest enclosing `def' block and uses\nthat. Else signals an error.\n\nWhen an enclosing def is found: The mark is left immediately beyond\nthe last line of the def block. Point is left at the start of the\ndef, except that: if the def is preceded by a number of comment lines\nfollowed by (at most) one optional blank line, point is left at the\nstart of the comments; else if the def is preceded by a blank line,\npoint is left at its start.\n\nThe intent is to mark the containing def/class and its associated\ndocumentation, to make moving and duplicating functions and classes\npleasant.\"\n (interactive \"P\") ; raw prefix arg\n (let ((start (point))\n (which (cond ((eq class 'either) \"\\\\(type\\\\|let\\\\)\")\n (class \"type\")\n (t \"let\"))))\n (push-mark start)\n (if (not (fsharp-go-up-tree-to-keyword which))\n (progn (goto-char start)\n (error \"Enclosing %s not found\"\n (if (eq class 'either)\n \"def or class\"\n which)))\n ;; else enclosing def/class found\n (setq start (point))\n (fsharp-goto-beyond-block)\n (push-mark (point))\n (goto-char start)\n (if (zerop (forward-line -1)) ; if there is a preceding line\n (progn\n (if (looking-at \"[ \\t]*$\") ; it's blank\n (setq start (point)) ; so reset start point\n (goto-char start)) ; else try again\n (if (zerop (forward-line -1))\n (if (looking-at \"[ \\t]*//\") ; a comment\n ;; look back for non-comment line\n ;; tricky: note that the regexp matches a blank\n ;; line, cuz \\n is in the 2nd character class\n (and\n (re-search-backward \"^[ \\t]*\\\\([^ \\t]\\\\|//\\\\)\" nil 'move)\n (forward-line 1))\n ;; no comment, so go back\n (goto-char start)))))))\n (exchange-point-and-mark))\n\n\n;;------------------------------- SMIE Configs -------------------------------;;\n\n(defconst fsharp-smie-grammar\n ;; SMIE grammar follow the refernce of SML-mode.\n (smie-prec2->grammar\n (smie-merge-prec2s\n (smie-bnf->prec2\n '((id)\n (expr (\"while\" expr \"do\" expr)\n (\"if\" expr \"then\" expr \"else\" expr)\n (\"for\" expr \"in\" expr \"do\" expr)\n (\"for\" expr \"to\" expr \"do\" expr)\n (\"try\" expr \"with\" branches)\n (\"try\" expr \"finally\" expr)\n (\"match\" expr \"with\" branches)\n (\"type\" expr \"=\" branches)\n (\"begin\" exprs \"end\")\n (\"[\" exprs \"]\")\n (\"[|\" exprs \"|]\")\n (\"{\" exprs \"}\")\n (\"<@\" exprs \"@>\")\n (\"<@@\" exprs \"@@>\")\n (\"let\" sexp \"=\" expr)\n (\"fun\" expr \"->\" expr))\n (sexp (\"rec\")\n (sexp \":\" type)\n (sexp \"||\" sexp)\n (sexp \"&&\" sexp)\n (\"(\" exprs \")\"))\n (exprs (exprs \";\" exprs)\n (exprs \",\" exprs)\n (expr))\n (type (type \"->\" type)\n (type \"*\" type))\n (branches (branches \"|\" branches))\n (decls (sexp \"=\" expr))\n (toplevel (decls)\n (expr)\n (toplevel \";;\" toplevel)))\n '((assoc \"|\"))\n '((assoc \"->\") (assoc \"*\"))\n '((assoc \"let\" \"fun\" \"type\" \"open\" \"->\"))\n '((assoc \"let\") (assoc \"=\"))\n '((assoc \"[\" \"]\" \"[|\" \"|]\" \"{\" \"}\"))\n '((assoc \"<@\" \"@>\"))\n '((assoc \"<@@\" \"@@>\"))\n '((assoc \"&&\") (assoc \"||\") (noassoc \":\"))\n '((assoc \";\") (assoc \",\"))\n '((assoc \";;\")))\n (smie-precs->prec2\n '((nonassoc (\">\" \">=\" \"<>\" \"<\" \"<=\" \"=\"))\n (assoc \"::\")\n (assoc \"+\" \"-\" \"^\")\n (assoc \"/\" \"*\" \"%\")))))\n )\n\n(defun fsharp-smie-rules (kind token)\n (pcase (cons kind token)\n (`(:elem . basic) fsharp-indent-offset)\n (`(:after . \"do\") fsharp-indent-offset)\n (`(:after . \"then\") fsharp-indent-offset)\n (`(:after . \"else\") fsharp-indent-offset)\n (`(:after . \"try\") fsharp-indent-offset)\n (`(:after . \"with\") fsharp-indent-offset)\n (`(:after . \"finally\") fsharp-indent-offset)\n (`(:after . \"in\") 0)\n (`(:after . ,(or `\"[\" `\"]\" `\"[|\" `\"|]\")) fsharp-indent-offset)\n (`(,_ . ,(or `\";\" `\",\")) (if (smie-rule-parent-p \"begin\")\n 0\n (smie-rule-separator kind)))\n (`(:after . \"=\") fsharp-indent-offset)\n (`(:after . \";;\") (smie-rule-separator kind))\n (`(:before . \";;\") (if (smie-rule-bolp)\n 0))\n ))\n\n\n(defun fsharp-mode-indent-smie-setup ()\n (smie-setup fsharp-smie-grammar #'fsharp-smie-rules))\n\n\n(provide 'fsharp-mode-structure)\n;;; fsharp-mode-structure.el ends here\n" }, { "path": "fsharp-mode-util.el", "content": ";;; fsharp-mode-util.el --- utility functions -*- lexical-binding: t -*-\n\n;; Copyright (C) 2015 Robin Neatherway\n\n;; Author: 2015 Robin Neatherway \n;; Maintainer: Robin Neatherway \n;; Keywords: languages\n\n;; This file is not part of GNU Emacs.\n\n;; This file is free software; you can redistribute it and/or modify\n;; it under the terms of the GNU General Public License as published by\n;; the Free Software Foundation; either version 3, or (at your option)\n;; any later version.\n\n;; This file is distributed in the hope that it will be useful,\n;; but WITHOUT ANY WARRANTY; without even the implied warranty of\n;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n;; GNU General Public License for more details.\n\n;; You should have received a copy of the GNU General Public License\n;; along with GNU Emacs; see the file COPYING. If not, write to\n;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,\n;; Boston, MA 02110-1301, USA.\n\n(require 'cl-lib)\n\n(defvar fsharp-ac-using-mono\n (cl-case system-type\n ((windows-nt cygwin msdos) nil)\n (otherwise t))\n \"Whether the .NET runtime in use is mono.\nDefaults to nil for Microsoft platforms (including Cygwin), t\nfor all *nix.\")\n\n(defun fsharp-mode--program-files-x86 ()\n (file-name-as-directory\n (or (getenv \"ProgramFiles(x86)\")\n (getenv \"ProgramFiles\")\n \"C:\\\\Program Files (x86)\")))\n\n(defun fsharp-mode--vs2017-msbuild-find (exe)\n \"Return EXE absolute path for Visual Studio 2017, if existent, else nil.\"\n (let ((candidates (mapcar (lambda (edition)\n (concat (fsharp-mode--program-files-x86)\n edition\n \"msbuild/15.0/bin/\"\n exe))\n '(\"Enterprise/\" \"Professional/\"\n \"Community/\" \"BuildTools/\"))))\n (cl-find-if (lambda (exe) (file-executable-p exe)) candidates)))\n\n(defun fsharp-mode--msbuild-find (exe)\n (if fsharp-ac-using-mono\n (executable-find exe)\n (let* ((searchdirs (mapcar (lambda (ver)\n (concat (fsharp-mode--program-files-x86)\n \"MSBuild/\" ver \"/Bin\"))\n '(\"14.0\" \"13.0\" \"12.0\")))\n (exec-path (append searchdirs exec-path)))\n (or (fsharp-mode--vs2017-msbuild-find exe) (executable-find exe)))))\n\n(defun fsharp-mode--executable-find (exe)\n (if fsharp-ac-using-mono\n (executable-find exe)\n (let* ((searchdirs (mapcar (lambda (ver)\n (concat (fsharp-mode--program-files-x86)\n \"Microsoft SDKs/F#/\"\n ver \"/Framework/v4.0\"))\n '(\"10.1\" \"4.0\" \"3.1\" \"3.0\")))\n (exec-path (append searchdirs exec-path)))\n (executable-find exe))))\n\n(provide 'fsharp-mode-util)\n\n;;; fsharp-mode-util.el ends here\n" }, { "path": "fsharp-mode.el", "content": ";;; fsharp-mode.el --- Support for the F# programming language\n\n;; Copyright (C) 1997 INRIA\n\n;; Author: 1993-1997 Xavier Leroy, Jacques Garrigue and Ian T Zimmerman\n;; 2010-2011 Laurent Le Brun \n;; 2012-2014 Robin Neatherway \n;; 2017-2023 Jürgen Hötzel\n;; Maintainer: Jürgen Hötzel\n;; Package-Requires: ((emacs \"25\"))\n;; Keywords: languages\n;; Version: 1.11-snapshot\n\n;; This file is not part of GNU Emacs.\n\n;; This file is free software; you can redistribute it and/or modify\n;; it under the terms of the GNU General Public License as published by\n;; the Free Software Foundation; either version 3, or (at your option)\n;; any later version.\n\n;; This file is distributed in the hope that it will be useful,\n;; but WITHOUT ANY WARRANTY; without even the implied warranty of\n;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n;; GNU General Public License for more details.\n\n;; You should have received a copy of the GNU General Public License\n;; along with GNU Emacs; see the file COPYING. If not, write to\n;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,\n;; Boston, MA 02110-1301, USA.\n\n;;; Code:\n\n(require 'fsharp-mode-structure)\n(require 'inf-fsharp-mode)\n(require 'fsharp-mode-util)\n(require 'compile)\n(require 'project)\n(require 'subr-x)\n(require 'seq)\n\n(defgroup fsharp nil\n \"Support for the Fsharp programming language, \"\n :group 'languages\n :prefix \"fsharp-\")\n\n;;; Compilation\n\n(defvar fsharp-compile-command\n (seq-some #'fsharp-mode--executable-find '(\"fsharpc\" \"fsc\"))\n \"The program used to compile F# source files.\")\n\n(defvar fsharp-build-command\n (seq-some #'fsharp-mode--msbuild-find '(\"msbuild\" \"xbuild\"))\n \"The command used to build F# projects and solutions.\")\n\n;;; ----------------------------------------------------------------------------\n\n(defvar fsharp-shell-active nil\n \"Non nil when a subshell is running.\")\n\n(defvar running-xemacs (string-match \"XEmacs\" emacs-version)\n \"Non-nil if we are running in the XEmacs environment.\")\n\n(defvar fsharp-mode-map nil\n \"Keymap used in fsharp mode.\")\n\n(unless fsharp-mode-map\n (setq fsharp-mode-map (make-sparse-keymap))\n (if running-xemacs\n (define-key fsharp-mode-map 'backspace 'backward-delete-char-untabify)\n (define-key fsharp-mode-map \"\\177\" 'backward-delete-char-untabify))\n\n ;; F# bindings\n (define-key fsharp-mode-map \"\\C-c\\C-a\" 'fsharp-find-alternate-file)\n (define-key fsharp-mode-map \"\\C-c\\C-c\" 'compile)\n (define-key fsharp-mode-map \"\\M-\\C-x\" 'fsharp-eval-phrase)\n (define-key fsharp-mode-map \"\\C-c\\C-e\" 'fsharp-eval-phrase)\n (define-key fsharp-mode-map \"\\C-x\\C-e\" 'fsharp-eval-phrase)\n (define-key fsharp-mode-map \"\\C-c\\C-r\" 'fsharp-eval-region)\n (define-key fsharp-mode-map \"\\C-c\\C-f\" 'fsharp-load-buffer-file)\n (define-key fsharp-mode-map \"\\C-c\\C-s\" 'fsharp-show-subshell)\n (define-key fsharp-mode-map \"\\M-\\C-h\" 'fsharp-mark-phrase)\n\n (define-key fsharp-mode-map (kbd \"M-n\") 'next-error)\n (define-key fsharp-mode-map (kbd \"M-p\") 'previous-error)\n\n (define-key fsharp-mode-map \"\\C-c<\" 'fsharp-shift-region-left)\n (define-key fsharp-mode-map \"\\C-c>\" 'fsharp-shift-region-right)\n\n (define-key fsharp-mode-map \"\\C-m\" 'fsharp-newline-and-indent)\n (define-key fsharp-mode-map \"\\C-c:\" 'fsharp-guess-indent-offset)\n\n (define-key fsharp-mode-map (kbd \"C-c \") 'fsharp-goto-block-up)\n\n (unless running-xemacs\n (let ((map (make-sparse-keymap \"fsharp\"))\n (forms (make-sparse-keymap \"Forms\")))\n (define-key fsharp-mode-map [menu-bar] (make-sparse-keymap))\n (define-key fsharp-mode-map [menu-bar fsharp] (cons \"F#\" map))\n\n (define-key map [goto-block-up] '(\"Goto block up\" . fsharp-goto-block-up))\n (define-key map [mark-phrase] '(\"Mark phrase\" . fsharp-mark-phrase))\n (define-key map [shift-left] '(\"Shift region to right\" . fsharp-shift-region-right))\n (define-key map [shift-right] '(\"Shift region to left\" . fsharp-shift-region-left))\n (define-key map [separator-2] '(\"---\"))\n\n ;; others\n (define-key map [compile] '(\"Compile...\" . compile))\n (define-key map [switch-view] '(\"Switch view\" . fsharp-find-alternate-file))\n (define-key map [separator-1] '(\"--\"))\n (define-key map [show-subshell] '(\"Show subshell\" . fsharp-show-subshell))\n (define-key map [eval-region] '(\"Eval region\" . fsharp-eval-region))\n (define-key map [eval-phrase] '(\"Eval phrase\" . fsharp-eval-phrase)))))\n\n;;;###autoload\n(progn\n (add-to-list 'auto-mode-alist '(\"\\\\.fs[iylx]?\\\\'\" . fsharp-mode))\n (add-to-list 'auto-mode-alist '(\"\\\\.fsproj\\\\'\" . nxml-mode)))\n\n(defvar fsharp-mode-syntax-table nil\n \"Syntax table in use in fsharp mode buffers.\")\n(unless fsharp-mode-syntax-table\n (setq fsharp-mode-syntax-table (make-syntax-table))\n ; backslash is an escape sequence\n (modify-syntax-entry ?\\\\ \"\\\\\" fsharp-mode-syntax-table)\n\n ; ( is first character of comment start\n (modify-syntax-entry ?\\( \"()1n\" fsharp-mode-syntax-table)\n ; * is second character of comment start,\n ; and first character of comment end\n (modify-syntax-entry ?* \". 23n\" fsharp-mode-syntax-table)\n ; ) is last character of comment end\n (modify-syntax-entry ?\\) \")(4n\" fsharp-mode-syntax-table)\n\n ; // is the beginning of a comment \"b\"\n (modify-syntax-entry ?/ \". 12b\" fsharp-mode-syntax-table)\n ; // \\n is the end of a comment \"b\"\n (modify-syntax-entry ?\\n \"> b\" fsharp-mode-syntax-table)\n\n ; quote and underscore are part of symbols\n ; so are # and ! as they can form part of types/preprocessor\n ; directives and also keywords\n (modify-syntax-entry ?' \"_\" fsharp-mode-syntax-table)\n (modify-syntax-entry ?_ \"_\" fsharp-mode-syntax-table)\n (modify-syntax-entry ?# \"_\" fsharp-mode-syntax-table)\n (modify-syntax-entry ?! \"_\" fsharp-mode-syntax-table)\n\n ; ISO-latin accented letters and EUC kanjis are part of words\n (let ((i 160))\n (while (< i 256)\n (modify-syntax-entry i \"w\" fsharp-mode-syntax-table)\n (setq i (1+ i)))))\n\n;; Other internal variables\n\n(defvar fsharp-last-noncomment-pos nil\n \"Caches last buffer position determined not inside a fsharp comment.\")\n(make-variable-buffer-local 'fsharp-last-noncomment-pos)\n\n;; last-noncomment-pos can be a simple position, because we nil it\n;; anyway whenever buffer changes upstream. last-comment-start and -end\n;; have to be markers, because we preserve them when the changes' end\n;; doesn't overlap with the comment's start.\n\n(defvar fsharp-last-comment-start nil\n \"A marker caching last determined fsharp comment start.\")\n(make-variable-buffer-local 'fsharp-last-comment-start)\n\n(defvar fsharp-last-comment-end nil\n \"A marker caching last determined fsharp comment end.\")\n(make-variable-buffer-local 'fsharp-last-comment-end)\n\n(defvar fsharp-mode-hook nil\n \"Hook for fsharp-mode\")\n\n(defcustom fsharp-autosave-on-file-load nil\n \"Determine if buffer should be automatically saved on\n`fsharp-load-buffer-file'.\nIf set to t, the buffer will always be saved, silently.\"\n :type 'boolean\n :group 'fsharp-mode)\n\n;;;###autoload\n(define-derived-mode fsharp-mode prog-mode \"fsharp\"\n :syntax-table fsharp-mode-syntax-table\n \"Major mode for editing fsharp code.\n\n\\\\{fsharp-mode-map}\"\n\n (require 'fsharp-mode-font)\n\n (fsharp-mode-indent-smie-setup)\n\n (use-local-map fsharp-mode-map)\n\n (mapc 'make-local-variable\n '(paragraph-start\n require-final-newline\n paragraph-separate\n paragraph-ignore-fill-prefix\n comment-start\n comment-end\n comment-column\n comment-start-skip\n comment-indent-function\n adaptive-fill-regexp\n parse-sexp-ignore-comments\n indent-region-function\n indent-line-function\n add-log-current-defun-function\n underline-minimum-offset\n compile-command\n syntax-propertize-function))\n\n (setq local-abbrev-table fsharp-mode-abbrev-table\n paragraph-start (concat \"^$\\\\|\" page-delimiter)\n paragraph-separate paragraph-start\n require-final-newline 'visit-save\n indent-tabs-mode nil\n comment-start \"//\"\n comment-end \"\"\n comment-column 40\n comment-start-skip \"///* *\"\n adaptive-fill-regexp \"[ \\t]*\\\\(//+[ \\t]*\\\\)*\"\n comment-indent-function 'fsharp-comment-indent-function\n indent-region-function 'fsharp-indent-region\n indent-line-function 'fsharp-indent-line\n underline-minimum-offset 4\n\n paragraph-ignore-fill-prefix t\n add-log-current-defun-function 'fsharp-current-defun\n fsharp-last-noncomment-pos nil\n fsharp-last-comment-start (make-marker)\n fsharp-last-comment-end (make-marker))\n\n ; Syntax highlighting\n (setq font-lock-defaults '(fsharp-font-lock-keywords))\n (setq syntax-propertize-function 'fsharp--syntax-propertize-function)\n ; Some reasonable defaults for company mode\n ;; In Emacs 24.4 onwards, tell electric-indent-mode that fsharp-mode\n ;; has no deterministic indentation.\n (when (boundp 'electric-indent-inhibit) (setq electric-indent-inhibit t))\n\n (when-let ((file (buffer-file-name)))\n (setq compile-command (fsharp-mode-choose-compile-command file))))\n\n(defun fsharp-mode-choose-compile-command (file)\n \"Format an appropriate compilation command, depending on several factors:\n1. The presence of a makefile\n2. The presence of a .sln or .fsproj\n3. The file's type.\n\"\n (let* ((fname (file-name-nondirectory file))\n (dname (file-name-directory file))\n (ext (file-name-extension file))\n (proj (fsharp-mode/find-sln-or-fsproj file))\n (makefile (or (file-exists-p (concat dname \"/Makefile\"))\n (file-exists-p (concat dname \"/makefile\")))))\n (cond\n (makefile compile-command)\n ((and fsharp-build-command proj) (combine-and-quote-strings `(,fsharp-build-command \"/nologo\" ,proj)))\n ((and fsharp-compile-command (member ext '(\"fs\" \"fsx\"))) (combine-and-quote-strings `(,fsharp-compile-command \"--nologo\" ,file)))\n ((equal ext \"fsl\") (combine-and-quote-strings (list \"fslex\" file)))\n ((equal ext \"fsy\") (combine-and-quote-strings (list \"fsyacc\" file)))\n (t compile-command))))\n\n(defun fsharp-find-alternate-file ()\n (interactive)\n (let ((name (buffer-file-name)))\n (if (string-match \"^\\\\(.*\\\\)\\\\.\\\\(fs\\\\|fsi\\\\)$\" name)\n (find-file\n (concat\n (fsharp-match-string 1 name)\n (if (string= \"fs\" (fsharp-match-string 2 name)) \".fsi\" \".fs\"))))))\n\n;;; Subshell support\n\n(defun fsharp-eval-region (start end)\n \"Send the current region to the inferior fsharp process.\"\n (interactive\"r\")\n (require 'inf-fsharp-mode)\n (inferior-fsharp-eval-region start end))\n\n(defun fsharp-eval-phrase ()\n \"Send current phrase to the interactive mode\"\n (interactive)\n (save-excursion\n (let ((p1) (p2))\n (fsharp-beginning-of-block)\n (setq p1 (point))\n (fsharp-end-of-block)\n (setq p2 (point))\n (fsharp-eval-region p1 p2))))\n\n(defun fsharp-load-buffer-file ()\n \"Load the filename corresponding to the present buffer in F# with #load\"\n (interactive)\n (require 'inf-fsharp-mode)\n (let* ((name buffer-file-name)\n (command (concat \"#load \\\"\" name \"\\\"\")))\n (when (and (buffer-modified-p)\n\t (or fsharp-autosave-on-file-load\n\t\t (y-or-n-p (concat \"Do you want to save \\\"\" name\n\t\t\t\t \"\\\" before loading it? \"))))\n (save-buffer))\n (fsharp-run-process-if-needed)\n (fsharp-simple-send inferior-fsharp-buffer-name command)))\n\n(defun fsharp-show-subshell ()\n (interactive)\n (require 'inf-fsharp-mode)\n (inferior-fsharp-show-subshell))\n\n(defconst fsharp-error-regexp-fs\n \"^\\\\([^(\\n]+\\\\)(\\\\([0-9]+\\\\),\\\\([0-9]+\\\\)):\"\n \"Regular expression matching the error messages produced by fsc.\")\n\n(if (boundp 'compilation-error-regexp-alist)\n (or (memq 'fsharp\n compilation-error-regexp-alist)\n (progn\n (add-to-list 'compilation-error-regexp-alist 'fsharp)\n (add-to-list 'compilation-error-regexp-alist-alist\n `(fsharp ,fsharp-error-regexp-fs 1 2 3)))))\n\n;; Usual match-string doesn't work properly with font-lock-mode\n;; on some emacs.\n\n(defun fsharp-match-string (num &optional string)\n\n \"Return string of text matched by last search, without properties.\n\nNUM specifies which parenthesized expression in the last regexp.\nValue is nil if NUMth pair didn't match, or there were less than NUM\npairs. Zero means the entire text matched by the whole regexp or\nwhole string.\"\n\n (let* ((data (match-data))\n (begin (nth (* 2 num) data))\n (end (nth (1+ (* 2 num)) data)))\n (if string (substring string begin end)\n (buffer-substring-no-properties begin end))))\n\n;;; Project\n\n(defun fsharp-mode/find-sln-or-fsproj (dir-or-file)\n \"Search for a solution or F# project file in any enclosing\nfolders relative to DIR-OR-FILE.\"\n (fsharp-mode-search-upwards (rx (0+ nonl) (or \".fsproj\" \".sln\") eol)\n (file-name-directory dir-or-file)))\n\n(defun fsharp-mode-search-upwards (regex dir)\n (when dir\n (or (car-safe (directory-files dir 'full regex))\n (fsharp-mode-search-upwards regex (fsharp-mode-parent-dir dir)))))\n\n(defun fsharp-mode-parent-dir (dir)\n (let ((p (file-name-directory (directory-file-name dir))))\n (unless (equal p dir)\n p)))\n\n;; Make project.el aware of fsharp projects\n(defun fsharp-mode-project-root (dir)\n (when-let (project-file (fsharp-mode/find-sln-or-fsproj dir))\n (cons 'fsharp (file-name-directory project-file))))\n\n(cl-defmethod project-roots ((project (head fsharp)))\n (list (cdr project)))\n\n(add-hook 'project-find-functions #'fsharp-mode-project-root)\n\n(provide 'fsharp-mode)\n\n;;; fsharp-mode.el ends here\n" }, { "path": "inf-fsharp-mode.el", "content": ";;; inf-fsharp-mode.el --- Support for F# interactive\n\n;; Copyright (C) 1997 INRIA\n\n;; Author: 1993-1997 Xavier Leroy, Jacques Garrigue\n;; 2010-2011 Laurent Le Brun \n;; Maintainer: Robin Neatherway \n;; Keywords: languages\n\n;; This file is not part of GNU Emacs.\n\n;; This file is free software; you can redistribute it and/or modify\n;; it under the terms of the GNU General Public License as published by\n;; the Free Software Foundation; either version 3, or (at your option)\n;; any later version.\n\n;; This file is distributed in the hope that it will be useful,\n;; but WITHOUT ANY WARRANTY; without even the implied warranty of\n;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n;; GNU General Public License for more details.\n\n;; You should have received a copy of the GNU General Public License\n;; along with GNU Emacs; see the file COPYING. If not, write to\n;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,\n;; Boston, MA 02110-1301, USA.\n\n(require 'tramp)\n(require 'comint)\n(require 'fsharp-mode-util)\n\n(require 'cl-lib)\n\n;; User modifiable variables\n\n;; Whether you want the output buffer to be diplayed when you send a phrase\n\n(defvar fsharp-display-when-eval t\n \"*If true, display the inferior fsharp buffer when evaluating expressions.\")\n\n(defvar inferior-fsharp-program\n (cond\n ((executable-find \"dotnet\") \"dotnet fsi --readline-\")\n (fsharp-ac-using-mono \"fsharpi --readline-\")\n (t (concat \"\\\"\" (fsharp-mode--executable-find \"fsi.exe\") \"\\\" --fsi-server-input-codepage:65001\")))\n \"Inferior F# command.\")\n\n;; End of User modifiable variables\n\n\n(defvar inferior-fsharp-mode-map\n (let ((map (copy-keymap comint-mode-map)))\n (define-key map [M-return] 'fsharp-comint-send)\n map))\n\n;; Augment fsharp mode, so you can process fsharp code in the source files.\n\n(define-derived-mode inferior-fsharp-mode comint-mode \"Inferior fsharp\"\n \"Major mode for interacting with an inferior fsharp process.\nRuns a fsharp toplevel as a subprocess of Emacs, with I/O through an\nEmacs buffer. A history of input phrases is maintained. Phrases can\nbe sent from another buffer in fsharp mode.\n\n\\\\{inferior-fsharp-mode-map}\"\n (setq comint-prompt-regexp \"^> ?\")\n (setq comint-prompt-read-only t)\n\n (set (make-local-variable 'paragraph-start) (concat \"^$\\\\|\" page-delimiter))\n (set (make-local-variable 'paragraph-separate) paragraph-start)\n (set (make-local-variable 'paragraph-ignore-fill-prefix) t)\n (set (make-local-variable 'require-final-newline) t)\n (set (make-local-variable 'comment-start) \"(*\")\n (set (make-local-variable 'comment-end) \"*)\")\n (set (make-local-variable 'comment-column) 40)\n (set (make-local-variable 'comment-start-skip) \"(\\\\*+ *\")\n (set (make-local-variable 'parse-sexp-ignore-comments) nil)\n (set (make-local-variable 'comint-process-echoes) t)\n (run-hooks 'inferior-fsharp-mode-hooks)\n\n ;; use compilation mode to parse errors, but RET and C-cC-c should still be from comint-mode\n (compilation-minor-mode)\n (make-local-variable 'minor-mode-map-alist)\n (setq minor-mode-map-alist (assq-delete-all 'compilation-minor-mode (cl-copy-seq minor-mode-map-alist))))\n\n(defconst inferior-fsharp-buffer-subname \"inferior-fsharp\")\n(defconst inferior-fsharp-buffer-name\n (concat \"*\" inferior-fsharp-buffer-subname \"*\"))\n\n(defun fsharp--localname (file)\n \"Return localname of a Tramp filename.\nIf FILE is not a Tramp filename return FILENAME\"\n (if (tramp-tramp-file-p file)\n (with-parsed-tramp-file-name file nil\n\tlocalname)\n file))\n\n(defun fsharp-run-process-if-needed (&optional cmd)\n \"Launch fsi if needed, using CMD if supplied.\"\n (unless (comint-check-proc inferior-fsharp-buffer-name)\n (setq inferior-fsharp-program\n (or cmd (read-from-minibuffer \"fsharp toplevel to run: \"\n inferior-fsharp-program)))\n (let ((cmdlist (inferior-fsharp-args-to-list inferior-fsharp-program))\n (process-connection-type 'pty))\n (with-current-buffer (apply (function make-comint)\n inferior-fsharp-buffer-subname\n (car cmdlist) nil\n (cdr cmdlist))\n (when (eq system-type 'windows-nt)\n (set-process-coding-system (get-buffer-process (current-buffer))\n 'utf-8 'utf-8))\n (inferior-fsharp-mode))\n (display-buffer inferior-fsharp-buffer-name))))\n\n;;;###autoload\n(defun run-fsharp (&optional cmd)\n \"Run an inferior fsharp process.\nInput and output via buffer `*inferior-fsharp*'.\"\n (interactive\n (list (if (not (comint-check-proc inferior-fsharp-buffer-name))\n (read-from-minibuffer \"fsharp toplevel to run: \"\n inferior-fsharp-program))))\n (fsharp-run-process-if-needed cmd)\n (switch-to-buffer-other-window inferior-fsharp-buffer-name))\n\n;; split the command line (e.g. \"mono fsi\" -> (\"mono\" \"fsi\"))\n;; we double the \\ before unquoting, so that the user doesn't have to\n(defun inferior-fsharp-args-to-list (string)\n (split-string-and-unquote (replace-regexp-in-string \"\\\\\\\\\" \"\\\\\\\\\\\\\\\\\" string)))\n\n(defun inferior-fsharp-show-subshell ()\n (interactive)\n (fsharp-run-process-if-needed)\n (display-buffer inferior-fsharp-buffer-name)\n\n (let ((buf (current-buffer))\n (fsharp-buf (get-buffer inferior-fsharp-buffer-name))\n (count 0))\n (while\n (and (< count 10)\n (not (equal (buffer-name (current-buffer))\n inferior-fsharp-buffer-name)))\n (next-multiframe-window)\n (setq count (+ count 1)))\n (if (equal (buffer-name (current-buffer))\n inferior-fsharp-buffer-name)\n (goto-char (point-max)))\n (while\n (> count 0)\n (previous-multiframe-window)\n (setq count (- count 1)))))\n\n(defun inferior-fsharp-eval-region (start end)\n \"Send the current region to the inferior fsharp process.\"\n (interactive \"r\")\n (fsharp-run-process-if-needed)\n ;; send location to fsi\n (let* ((name (file-truename (buffer-file-name (current-buffer))))\n (dir (fsharp--localname (file-name-directory name)))\n (line (number-to-string (line-number-at-pos start)))\n (loc (concat \"# \" line \" \\\"\" name \"\\\"\\n\"))\n (movedir (concat \"#silentCd @\\\"\" dir \"\\\";;\\n\")))\n (comint-send-string inferior-fsharp-buffer-name movedir)\n (comint-send-string inferior-fsharp-buffer-name loc))\n (save-excursion\n (goto-char end)\n (comint-send-region inferior-fsharp-buffer-name start (point))\n ;; normally, \";;\" are part of the region\n (if (and (>= (point) 2)\n (prog2 (backward-char 2) (looking-at \";;\")))\n (comint-send-string inferior-fsharp-buffer-name \"\\n\")\n (comint-send-string inferior-fsharp-buffer-name \"\\n;;\\n\"))\n ;; the user may not want to see the output buffer\n (if fsharp-display-when-eval\n (display-buffer inferior-fsharp-buffer-name t))))\n\n(defvar fsharp-previous-output nil\n \"tells the beginning of output in the shell-output buffer, so that the\noutput can be retreived later, asynchronously.\")\n\n;; To insert the last output from fsharp at point\n(defun fsharp-insert-last-output ()\n \"Insert the result of the evaluation of previous phrase\"\n (interactive)\n (let ((pos (process-mark (get-buffer-process inferior-fsharp-buffer-name))))\n (insert-buffer-substring inferior-fsharp-buffer-name\n fsharp-previous-output (- pos 2))))\n\n\n(defun fsharp-simple-send (proc string)\n (comint-simple-send proc (concat string \";;\")))\n\n(defun fsharp-comint-send ()\n (interactive)\n (let ((comint-input-sender 'fsharp-simple-send))\n (comint-send-input)))\n\n(provide 'inf-fsharp-mode)\n\n;;; inf-sharp-mode.el ends here\n" }, { "path": "test/CompileCommandData/Directory With Spaces/noproj/test.fs", "content": "" }, { "path": "test/CompileCommandData/Directory With Spaces/proj/test.fs", "content": "" }, { "path": "test/CompileCommandData/Directory With Spaces/proj/test.fsproj", "content": "" }, { "path": "test/CompileCommandData/noproj/test.fs", "content": "" }, { "path": "test/CompileCommandData/proj/Makefile", "content": "" }, { "path": "test/CompileCommandData/proj/test.fs", "content": "" }, { "path": "test/CompileCommandData/proj/test.fsproj", "content": "" }, { "path": "test/FindSlnData/bar.sln", "content": "" }, { "path": "test/FindSlnData/noproj/test.fs", "content": "" }, { "path": "test/FindSlnData/sln/foo.sln", "content": "" }, { "path": "test/FindSlnData/test.fsproj", "content": "" }, { "path": "test/StructureTest/Blocks.fs", "content": "let notABlock = 5\n\nlet basicBlock =\n [ 1; 2; 3 ]\n |> List.fold (fun x y -> x + y)\n\ntype Shape =\n | Square\n | Rectangle\n | Triangle\n\nlet aFunction x y =\n if x < y\n then\n x\n else\n y\n\n" }, { "path": "test/StructureTest/BracketIndent.fs", "content": "let formatOne = [ \"this\"\n \"that\"\n \"the-other\"\n\n ]\n\nlet formatTwo = [\n \"this\"\n \"that\"\n\n ]\n\nlet formatThree =\n [ \"this\"\n \"that\"\n \"the-other\"\n \"hi\"\n\n ]\n" }, { "path": "test/StructureTest/ContinuationLines.fs", "content": "let x = 5\nlet y =\n [ 1; 2 ]\n |> List.fold (fun x y -> x + y)\n\nlet z = 5 +\n 6\n" }, { "path": "test/StructureTest/Literals.fs", "content": "// Generated using https://hipsum.co/\n\n// I'm a longer comment! Now, with Hipster Lorem Ipsum:\n//\n// Lorem ipsum dolor amet man braid +1 palo santo, whatever retro taxidermy\n// quinoa cred venmo church-key. Pok pok cray cornhole selvage irony keytar\n// disrupt man braid, everyday carry intelligentsia pitchfork street art hell\n// of. Schlitz air plant beard, fam authentic health goth hella fashion axe palo\n// santo pok pok. Hell of post-ironic artisan put a bird on it shoreditch shabby\n// chic. Bitters 3 wolf moon food truck adaptogen.\n//\n// Paleo fanny pack poutine, williamsburg health goth four dollar toast\n// aesthetic. Tbh viral truffaut live-edge asymmetrical ramps chillwave ethical\n// keytar fixie post-ironic vaporware air plant intelligentsia. Wayfarers\n// flannel iceland, DIY meditation celiac green juice disrupt. Food truck paleo\n// bicycle rights cold-pressed roof party normcore tumblr.\n\nlet thisIsHereToBreakUpTheComments = 5\n\n(* This is the same thing, but in a different comment syntax. *)\n\n(* Lorem ipsum dolor amet man braid +1 palo santo, whatever retro taxidermy\nquinoa cred venmo church-key. Pok pok cray cornhole selvage irony keytar disrupt\nman braid, everyday carry intelligentsia pitchfork street art hell of. Schlitz\nair plant beard, fam authentic health goth hella fashion axe palo santo pok pok.\nHell of post-ironic artisan put a bird on it shoreditch shabby chic. Bitters 3\nwolf moon food truck adaptogen.\n\nPaleo fanny pack poutine, williamsburg health goth four dollar toast aesthetic.\nTbh viral truffaut live-edge asymmetrical ramps chillwave ethical keytar fixie\npost-ironic vaporware air plant intelligentsia. Wayfarers flannel iceland, DIY\nmeditation celiac green juice disrupt. Food truck paleo bicycle rights\ncold-pressed roof party normcore tumblr. *)\n\n/// Yet again the same thing, but in a doc comment.\n///\n/// Lorem ipsum dolor amet man braid +1 palo santo, whatever retro taxidermy\n/// quinoa cred venmo church-key. Pok pok cray cornhole selvage irony keytar\n/// disrupt man braid, everyday carry intelligentsia pitchfork street art hell\n/// of. Schlitz air plant beard, fam authentic health goth hella fashion axe\n/// palo santo pok pok. Hell of post-ironic artisan put a bird on it shoreditch\n/// shabby chic. Bitters 3 wolf moon food truck adaptogen.\n///\n/// Paleo fanny pack poutine, williamsburg health goth four dollar toast\n/// aesthetic. Tbh viral truffaut live-edge asymmetrical ramps chillwave ethical\n/// keytar fixie post-ironic vaporware air plant intelligentsia. Wayfarers\n/// flannel iceland, DIY meditation celiac green juice disrupt. Food truck paleo\n/// bicycle rights cold-pressed roof party normcore tumblr.\n\n\nlet simple = \"this is a very normal string\"\n\nlet stringInString = \"This contains another \\\"string\\\", so to speak.\"\n\nlet longer =\n \"\"\"\n This is a triple-quoted string\n \"\"\"\n\nlet evenLonger = \"\"\"\nThis string is very long and had \"normal extra quotes\" and also\na small number of \\\"escaped quotes\\\", and also a gratuitous it's.\n\"\"\"\n" }, { "path": "test/StructureTest/Nesting.fs", "content": "// This file contains hand-crafted structures for use by `fsharp-mode-structure-tests.el`.\n// In particular, many/most of those tests need to work by:\n//\n// 1. Inserting text in a temp buffer\n// 2. Moving point to a known position\n// 3. Comparing computed values against expected answers\n//\n// Frequently, we're comparing things like, \"what is the exact (point) position\n// of a given square brace.\" This means that formatting changes to this buffer\n// -- indeed, edits _of any kind_ -- will almost certainly break the tests! Edit\n// thoughtfully and intentionally! Update things as needed!\n\n// (point) of opening [: 640\nlet aList = [ 1; 2; 3]\n\n// (point) of inner opening [: 706\nlet nestedList = [ [ \"this\"; \"that\" ] ]\n\n// (point) of opening [: 777\nlet multiLineList = [\n \"this\"\n \"that\"\n]\n\n// (point) of outermost opening [: 947\n// (point) of middle opening [: 953\n// (point) of innermost opening [: 955\nlet multiLineNestedList = [\n [ [ \"how\"; \"now\"]\n ]\n]\n\n// (point) of opening {: 1060\n// (point) of inner {: 1121\nlet anAsync = async {\n let value = funCall()\n\n let! differentValue = async { return! 5 }\n}\n\n// (point) of opening (: 1208\nlet thing =\n [ 1; 2]\n |> List.map (fun i ->\n i ** i )\n" }, { "path": "test/StructureTest/Relative.fs", "content": "type Test =\n | Unit\n | Integration of string\n | EndToEnd\n\n\nif thing <> true then\n printfn \"thing is not true\"\nelse if thing = true\nthen\n printfn \"maybe?\"\nelse\n printfn \"it is so\"\n\n\nlet aThing (test : Test) = function\n | Unit -> ()\n | Integration -> ()\n | EndToEnd -> ()\n" }, { "path": "test/Test1/Error.fs", "content": "module Error\n\nlet x = nonexisting()\n\n" }, { "path": "test/Test1/FileTwo.fs", "content": "module FileTwo\n\ntype Foo =\n | Bar\n | Qux\n\nlet addition x y = x + y\n\nlet add x y = x + y\n\ntype NewObjectType() =\n\n member x.Terrific (y : int) : int =\n y\n" }, { "path": "test/Test1/NoProject.fs", "content": "module FileTwo\n\nopen System.Collection\n" }, { "path": "test/Test1/Pervasive.fs", "content": "let printtest args =\n printfn \"Hello %d\" 10\n 0\n" }, { "path": "test/Test1/Program.fs", "content": "module X =\n let func x = x + 1\n\nlet testval = FileTwo.NewObjectType()\n\nlet val2 = X.func 2\n\nlet val3 = testval.Terrific val2\n\nlet val4 : FileTwo.NewObjectType = testval\n\ntype Dummy = Foo | Bar\n\nlet val5:Dummy = Foo\n\n[]\nlet main args =\n printfn \"Hello %d\" val2\n 0\n" }, { "path": "test/Test1/Script.fsx", "content": "\n\nmodule XA =\n let funky x = x + 1\n\nlet val99 = XA.funky 21\n" }, { "path": "test/Test1/Test1.fsproj", "content": "\n\n \n Exe\n net9.0\n \n\n \n \n \n \n \n \n\n\n" }, { "path": "test/Test2/Main.fs", "content": "module Test2.Main\n\nlet val2 = List.map ((+) 1) [1;2]\n\n[]\nlet main args =\n printfn \"Hello %A\" val2\n 0\n" }, { "path": "test/Test2/Test2.fsproj", "content": "\n\n \n Debug\n x86\n 8.0.30703\n 2.0\n {116cc2f9-f987-4b3d-915a-34cac04a73db}\n Library\n Test2\n Test2\n Test2\n False\n \n \n Program.fs\n \n \n 4.3.0.0\n 11\n \n \n True\n full\n False\n False\n bin\\Debug\\\n DEBUG;TRACE\n 3\n x86\n bin\\Debug\\Test2.XML\n \n \n pdbonly\n True\n True\n bin\\Release\\\n TRACE\n 3\n x86\n bin\\Release\\Test2.XML\n False\n \n \n \n True\n \n \n \n \n \n {116cc2f9-f987-4b3d-915a-34cac04a73da}\n Test1\n \n \n \n \n \n \n \n \n $(MSBuildExtensionsPath32)\\..\\Microsoft SDKs\\F#\\3.0\\Framework\\v4.0\\Microsoft.FSharp.Targets\n \n \n \n \n $(MSBuildExtensionsPath32)\\Microsoft\\VisualStudio\\v$(VisualStudioVersion)\\FSharp\\Microsoft.FSharp.Targets\n \n \n \n \n \n\n" }, { "path": "test/apps/FQuake3/NativeMappings.fs", "content": "(*\nCopyright (C) 2013 William F. Smith\n\nThis program is free software; you can redistribute it\nand/or modify it under the terms of the GNU General Public License as\npublished by the Free Software Foundation; either version 2 of the License,\nor (at your option) any later version.\n\nThis program is distributed in the hope that it will be\nuseful, but WITHOUT ANY WARRANTY; without even the implied warranty of\nMERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\nGNU General Public License for more details.\n\nYou should have received a copy of the GNU General Public License\nalong with this program; if not, write to the Free Software\nFoundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA\n\nDerivative of Quake III Arena source:\nCopyright (C) 1999-2005 Id Software, Inc.\n*)\n\n// Disable native interop warnings\n#nowarn \"9\"\n#nowarn \"51\"\n\nnamespace Engine.Native\n\nopen System\nopen System.IO\nopen System.Runtime.InteropServices\nopen Microsoft.FSharp.NativeInterop\nopen FSharp.Game.Math\nopen Engine.Core\nopen Engine.Net\nopen Engine.FileSystem\nopen Engine.NativeInterop\nopen FQuake3.Math\nopen FQuake3.Md3\n\n/// Used to prevent massive copying of large immutable data.\nmodule private Cache =\n let mutable md3Map = Map.empty\n\nmodule Boolean =\n let inline ofNativePtr (ptr: nativeptr) =\n let mutable native = NativePtr.read ptr\n\n match native with\n | qboolean.qtrue -> true\n | _ -> false\n\n let inline toNativeByPtr (ptr: nativeptr) (value: bool) =\n let mutable native = NativePtr.read ptr\n\n native <- if value then qboolean.qtrue else qboolean.qfalse\n\n NativePtr.write ptr native\n\n let inline toNative (value: bool) =\n if value then qboolean.qtrue else qboolean.qfalse\n\nmodule Vec2 =\n let inline ofNativePtr (ptr: nativeptr) =\n let mutable native = NativePtr.read ptr\n\n vec2 (native.value, native.value1)\n\n let inline toNativeByPtr (ptr: nativeptr) (v: vec2) =\n let mutable native = NativePtr.read ptr\n\n native.value <- v.X\n native.value1 <- v.Y\n\n NativePtr.write ptr native \n\nmodule Vec3 =\n let inline ofNativePtr (ptr: nativeptr) =\n let mutable native = NativePtr.read ptr\n\n vec3 (native.value, native.value1, native.value2)\n\n let inline toNativeByPtr (ptr: nativeptr) (v: vec3) =\n let mutable native = NativePtr.read ptr\n\n native.value <- v.X\n native.value1 <- v.Y\n native.value2 <- v.Z\n\n NativePtr.write ptr native \n \nmodule Vec4 =\n let inline ofNativePtr (ptr: nativeptr) =\n let mutable native = NativePtr.read ptr\n\n vec4 (native.value, native.value1, native.value2, native.value3)\n\n let inline toNativeByPtr (ptr: nativeptr) (v: vec4) =\n let mutable native = NativePtr.read ptr\n\n native.value <- v.X\n native.value1 <- v.Y\n native.value2 <- v.Z\n native.value3 <- v.W\n\n NativePtr.write ptr native \n\nmodule Mat4 =\n let inline ofNativePtr (ptr: nativeptr) =\n mat4 (\n (NativePtr.get ptr 0),\n (NativePtr.get ptr 1),\n (NativePtr.get ptr 2),\n (NativePtr.get ptr 3),\n (NativePtr.get ptr 4),\n (NativePtr.get ptr 5),\n (NativePtr.get ptr 6),\n (NativePtr.get ptr 7),\n (NativePtr.get ptr 8),\n (NativePtr.get ptr 9),\n (NativePtr.get ptr 10),\n (NativePtr.get ptr 11),\n (NativePtr.get ptr 12),\n (NativePtr.get ptr 13),\n (NativePtr.get ptr 14),\n (NativePtr.get ptr 15)\n )\n\n let inline toNativeByPtr (ptr: nativeptr) (m: mat4) =\n NativePtr.set ptr 0 m.[0, 0]\n NativePtr.set ptr 1 m.[0, 1]\n NativePtr.set ptr 2 m.[0, 2]\n NativePtr.set ptr 3 m.[0, 3]\n NativePtr.set ptr 4 m.[1, 0]\n NativePtr.set ptr 5 m.[1, 1]\n NativePtr.set ptr 6 m.[1, 2]\n NativePtr.set ptr 7 m.[1, 3]\n NativePtr.set ptr 8 m.[2, 0]\n NativePtr.set ptr 9 m.[2, 1]\n NativePtr.set ptr 10 m.[2, 2]\n NativePtr.set ptr 11 m.[2, 3]\n NativePtr.set ptr 12 m.[3, 0]\n NativePtr.set ptr 13 m.[3, 1]\n NativePtr.set ptr 14 m.[3, 2]\n NativePtr.set ptr 15 m.[3, 3]\n\nmodule Cvar =\n let inline ofNativePtr (ptr: nativeptr) =\n let mutable native = NativePtr.read ptr\n\n {\n Name = NativePtr.toStringAnsi native.name;\n String = NativePtr.toStringAnsi native.string;\n ResetString = NativePtr.toStringAnsi native.resetString;\n LatchedString = NativePtr.toStringAnsi native.latchedString;\n Flags = native.flags;\n IsModified = Boolean.ofNativePtr &&native.modified;\n ModificationCount = native.modificationCount;\n Value = native.value;\n Integer = native.integer;\n }\n\nmodule Bounds =\n let inline ofNativePtr (ptr: nativeptr) =\n Bounds (\n Vec3.ofNativePtr <| NativePtr.add ptr 0,\n Vec3.ofNativePtr <| NativePtr.add ptr 1)\n\n let inline toNativeByPtr (ptr: nativeptr) (bounds: Bounds) =\n let mutable nativeX = NativePtr.get ptr 0\n let mutable nativeY = NativePtr.get ptr 1\n\n Vec3.toNativeByPtr &&nativeX bounds.Min\n Vec3.toNativeByPtr &&nativeY bounds.Max\n\n NativePtr.set ptr 0 nativeX\n NativePtr.set ptr 1 nativeY\n\nmodule Message =\n let inline ofNativePtr (ptr: nativeptr) =\n let mutable native = NativePtr.read ptr\n\n {\n IsAllowedOverflow = Boolean.ofNativePtr &&native.allowoverflow;\n IsOverflowed = Boolean.ofNativePtr &&native.overflowed;\n IsOutOfBand = Boolean.ofNativePtr &&native.oob;\n Data = Seq.ofNativePtrArray native.cursize native.data;\n MaxSize = native.maxsize;\n ReadCount = native.readcount;\n Bit = native.bit;\n }\n\nmodule IPAddress =\n let inline ofNativePtr (ptr: nativeptr) =\n {\n Octet1 = NativePtr.get ptr 0;\n Octet2 = NativePtr.get ptr 1;\n Octet3 = NativePtr.get ptr 2;\n Octet4 = NativePtr.get ptr 3;\n }\n\nmodule Address =\n let inline ofNativePtr (ptr: nativeptr) =\n let mutable native = NativePtr.read ptr\n\n {\n Type = enum (int native.type');\n IP = IPAddress.ofNativePtr &&native.ip\n Port = native.port;\n }\n\nmodule Md3Frame =\n let inline ofNativePtr (ptr: nativeptr) =\n let mutable native = NativePtr.read ptr\n\n {\n Bounds = Bounds.ofNativePtr &&native.bounds;\n LocalOrigin = Vec3.ofNativePtr &&native.localOrigin;\n Radius = native.radius;\n Name = NativePtr.toStringAnsi &&native.name;\n }\n\nmodule Md3 =\n let ofNativePtr (ptr: nativeptr) =\n let mutable native = NativePtr.read ptr\n\n let hash = NativePtr.toNativeInt ptr\n\n match Map.tryFind hash Cache.md3Map with\n | Some x -> x\n | None ->\n\n let bytes = Array.zeroCreate native.ofsEnd\n Marshal.Copy (NativePtr.toNativeInt ptr, bytes, 0, native.ofsEnd)\n let md3 = FQuake3.Utils.Md3.parse bytes\n Cache.md3Map <- Map.add hash md3 Cache.md3Map\n md3\n\nmodule DirectoryInfo =\n let ofNativePtr (ptr: nativeptr) =\n let mutable native = NativePtr.read ptr\n\n let path = NativePtr.toStringAnsi &&native.path\n let name = NativePtr.toStringAnsi &&native.gamedir\n\n DirectoryInfo (Path.Combine (path, name))\n\nmodule Pak =\n let ofNativePtr (ptr: nativeptr) =\n let mutable native = NativePtr.read ptr\n\n {\n FileInfo = FileInfo (NativePtr.toStringAnsi &&native.pakFilename);\n Checksum = native.checksum;\n PureChecksum = native.checksum;\n FileCount = native.numfiles;\n }\n\nmodule ServerPakChecksum =\n let createFrom_fs_serverPaks (size: int) (ptr: nativeptr) =\n match NativePtr.isValid ptr with\n | false -> []\n | _ -> NativePtr.toList size ptr\n\nmodule SearchPath =\n let ofNativePtr (ptr: nativeptr) =\n let mutable native = NativePtr.read ptr\n\n {\n DirectoryInfo = Option.ofNativePtr DirectoryInfo.ofNativePtr native.directory\n }\n\n let convertFrom_fs_searchpaths (ptr: nativeptr) =\n let rec f (searchPaths: SearchPath list) (ptr: nativeptr) =\n match NativePtr.isValid ptr with\n | false -> searchPaths\n | _ ->\n let mutable native = NativePtr.read ptr\n f (ofNativePtr ptr :: searchPaths) (native.next)\n\n f [] ptr\n" }, { "path": "test/apps/FQuake3/NativeMappings.fs.faceup", "content": "«x:(*\nCopyright (C) 2013 William F. Smith\n\nThis program is free software; you can redistribute it\nand/or modify it under the terms of the GNU General Public License as\npublished by the Free Software Foundation; either version 2 of the License,\nor (at your option) any later version.\n\nThis program is distributed in the hope that it will be\nuseful, but WITHOUT ANY WARRANTY; without even the implied warranty of\nMERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\nGNU General Public License for more details.\n\nYou should have received a copy of the GNU General Public License\nalong with this program; if not, write to the Free Software\nFoundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA\n\nDerivative of Quake III Arena source:\nCopyright (C) 1999-2005 Id Software, Inc.\n*)»\n\n«m:// »«x:Disable native interop warnings\n»«k:#nowarn» «s:\"9\"»\n«k:#nowarn» «s:\"51\"»\n\n«k:namespace» «v:Engine».«v:Native»\n\n«k:open» «v:System»\n«k:open» «v:System».«v:IO»\n«k:open» «v:System».«v:Runtime».«v:InteropServices»\n«k:open» «v:Microsoft».«v:FSharp».«v:NativeInterop»\n«k:open» «v:FSharp».«v:Game».«v:Math»\n«k:open» «v:Engine».«v:Core»\n«k:open» «v:Engine».«v:Net»\n«k:open» «v:Engine».«v:FileSystem»\n«k:open» «v:Engine».«v:NativeInterop»\n«k:open» «v:FQuake3».«v:Math»\n«k:open» «v:FQuake3».«v:Md3»\n\n«m:/// »«x:Used to prevent massive copying of large immutable data.\n»«k:module» «k:private» «v:Cache» =\n «k:let» «k:mutable» «v:md3Map» = Map.empty\n\n«k:module» «t:Boolean» =\n «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») =\n «k:let» «k:mutable» «v:native» = NativePtr.read ptr\n\n «k:match» native «k:with»\n «:fsharp-ui-operator-face:|» qboolean.qtrue -> «k:true»\n «:fsharp-ui-operator-face:|» _ -> «k:false»\n\n «k:let» «k:inline» «f:toNativeByPtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») («v:value»: «t:bool») =\n «k:let» «k:mutable» «v:native» = NativePtr.read ptr\n\n native <- «k:if» value «k:then» qboolean.qtrue «k:else» qboolean.qfalse\n\n NativePtr.write ptr native\n\n «k:let» «k:inline» «f:toNative» («v:value»: «t:bool») =\n «k:if» value «k:then» qboolean.qtrue «k:else» qboolean.qfalse\n\n«k:module» «t:Vec2» =\n «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») =\n «k:let» «k:mutable» «v:native» = NativePtr.read ptr\n\n vec2 (native.value, native.value1)\n\n «k:let» «k:inline» «f:toNativeByPtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») («v:v»: «t:vec2») =\n «k:let» «k:mutable» «v:native» = NativePtr.read ptr\n\n native.value <- v.X\n native.value1 <- v.Y\n\n NativePtr.write ptr native \n\n«k:module» «t:Vec3» =\n «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») =\n «k:let» «k:mutable» «v:native» = NativePtr.read ptr\n\n vec3 (native.value, native.value1, native.value2)\n\n «k:let» «k:inline» «f:toNativeByPtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») («v:v»: «t:vec3») =\n «k:let» «k:mutable» «v:native» = NativePtr.read ptr\n\n native.value <- v.X\n native.value1 <- v.Y\n native.value2 <- v.Z\n\n NativePtr.write ptr native \n \n«k:module» «t:Vec4» =\n «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») =\n «k:let» «k:mutable» «v:native» = NativePtr.read ptr\n\n vec4 (native.value, native.value1, native.value2, native.value3)\n\n «k:let» «k:inline» «f:toNativeByPtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») («v:v»: «t:vec4») =\n «k:let» «k:mutable» «v:native» = NativePtr.read ptr\n\n native.value <- v.X\n native.value1 <- v.Y\n native.value2 <- v.Z\n native.value3 <- v.W\n\n NativePtr.write ptr native \n\n«k:module» «t:Mat4» =\n «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») =\n mat4 (\n (NativePtr.get ptr 0),\n (NativePtr.get ptr 1),\n (NativePtr.get ptr 2),\n (NativePtr.get ptr 3),\n (NativePtr.get ptr 4),\n (NativePtr.get ptr 5),\n (NativePtr.get ptr 6),\n (NativePtr.get ptr 7),\n (NativePtr.get ptr 8),\n (NativePtr.get ptr 9),\n (NativePtr.get ptr 10),\n (NativePtr.get ptr 11),\n (NativePtr.get ptr 12),\n (NativePtr.get ptr 13),\n (NativePtr.get ptr 14),\n (NativePtr.get ptr 15)\n )\n\n «k:let» «k:inline» «f:toNativeByPtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») («v:m»: «t:mat4») =\n NativePtr.set ptr 0 m.[0, 0]\n NativePtr.set ptr 1 m.[0, 1]\n NativePtr.set ptr 2 m.[0, 2]\n NativePtr.set ptr 3 m.[0, 3]\n NativePtr.set ptr 4 m.[1, 0]\n NativePtr.set ptr 5 m.[1, 1]\n NativePtr.set ptr 6 m.[1, 2]\n NativePtr.set ptr 7 m.[1, 3]\n NativePtr.set ptr 8 m.[2, 0]\n NativePtr.set ptr 9 m.[2, 1]\n NativePtr.set ptr 10 m.[2, 2]\n NativePtr.set ptr 11 m.[2, 3]\n NativePtr.set ptr 12 m.[3, 0]\n NativePtr.set ptr 13 m.[3, 1]\n NativePtr.set ptr 14 m.[3, 2]\n NativePtr.set ptr 15 m.[3, 3]\n\n«k:module» «t:Cvar» =\n «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») =\n «k:let» «k:mutable» «v:native» = NativePtr.read ptr\n\n {\n Name = NativePtr.toStringAnsi native.name;\n String = NativePtr.toStringAnsi native.string;\n ResetString = NativePtr.toStringAnsi native.resetString;\n LatchedString = NativePtr.toStringAnsi native.latchedString;\n Flags = native.flags;\n IsModified = Boolean.ofNativePtr &&native.modified;\n ModificationCount = native.modificationCount;\n Value = native.value;\n Integer = native.integer;\n }\n\n«k:module» «t:Bounds» =\n «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») =\n Bounds (\n Vec3.ofNativePtr «:fsharp-ui-operator-face:<|» NativePtr.add ptr 0,\n Vec3.ofNativePtr «:fsharp-ui-operator-face:<|» NativePtr.add ptr 1)\n\n «k:let» «k:inline» «f:toNativeByPtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») («v:bounds»: «t:Bounds») =\n «k:let» «k:mutable» «v:nativeX» = NativePtr.get ptr 0\n «k:let» «k:mutable» «v:nativeY» = NativePtr.get ptr 1\n\n Vec3.toNativeByPtr &&nativeX bounds.Min\n Vec3.toNativeByPtr &&nativeY bounds.Max\n\n NativePtr.set ptr 0 nativeX\n NativePtr.set ptr 1 nativeY\n\n«k:module» «t:Message» =\n «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») =\n «k:let» «k:mutable» «v:native» = NativePtr.read ptr\n\n {\n IsAllowedOverflow = Boolean.ofNativePtr &&native.allowoverflow;\n IsOverflowed = Boolean.ofNativePtr &&native.overflowed;\n IsOutOfBand = Boolean.ofNativePtr &&native.oob;\n Data = Seq.ofNativePtrArray native.cursize native.data;\n MaxSize = native.maxsize;\n ReadCount = native.readcount;\n Bit = native.bit;\n }\n\n«k:module» «t:IPAddress» =\n «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») =\n {\n Octet1 = NativePtr.get ptr 0;\n Octet2 = NativePtr.get ptr 1;\n Octet3 = NativePtr.get ptr 2;\n Octet4 = NativePtr.get ptr 3;\n }\n\n«k:module» «t:Address» =\n «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») =\n «k:let» «k:mutable» «v:native» = NativePtr.read ptr\n\n {\n Type = enum (int native.type');\n IP = IPAddress.ofNativePtr &&native.ip\n Port = native.port;\n }\n\n«k:module» «t:Md3Frame» =\n «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») =\n «k:let» «k:mutable» «v:native» = NativePtr.read ptr\n\n {\n Bounds = Bounds.ofNativePtr &&native.bounds;\n LocalOrigin = Vec3.ofNativePtr &&native.localOrigin;\n Radius = native.radius;\n Name = NativePtr.toStringAnsi &&native.name;\n }\n\n«k:module» «t:Md3» =\n «k:let» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») =\n «k:let» «k:mutable» «v:native» = NativePtr.read ptr\n\n «k:let» «v:hash» = NativePtr.toNativeInt ptr\n\n «k:match» Map.tryFind hash Cache.md3Map «k:with»\n «:fsharp-ui-operator-face:|» Some x -> x\n «:fsharp-ui-operator-face:|» None ->\n\n «k:let» «v:bytes» = Array.zeroCreate native.ofsEnd\n Marshal.Copy (NativePtr.toNativeInt ptr, bytes, 0, native.ofsEnd)\n «k:let» «v:md3» = FQuake3.Utils.Md3.parse bytes\n Cache.md3Map <- Map.add hash md3 Cache.md3Map\n md3\n\n«k:module» «t:DirectoryInfo» =\n «k:let» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») =\n «k:let» «k:mutable» «v:native» = NativePtr.read ptr\n\n «k:let» «v:path» = NativePtr.toStringAnsi &&native.path\n «k:let» «v:name» = NativePtr.toStringAnsi &&native.gamedir\n\n DirectoryInfo (Path.Combine (path, name))\n\n«k:module» «t:Pak» =\n «k:let» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») =\n «k:let» «k:mutable» «v:native» = NativePtr.read ptr\n\n {\n FileInfo = FileInfo (NativePtr.toStringAnsi &&native.pakFilename);\n Checksum = native.checksum;\n PureChecksum = native.checksum;\n FileCount = native.numfiles;\n }\n\n«k:module» «t:ServerPakChecksum» =\n «k:let» «f:createFrom_fs_serverPaks» («v:size»: «t:int») («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») =\n «k:match» NativePtr.isValid ptr «k:with»\n «:fsharp-ui-operator-face:|» «k:false» -> []\n «:fsharp-ui-operator-face:|» _ -> NativePtr.toList size ptr\n\n«k:module» «t:SearchPath» =\n «k:let» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») =\n «k:let» «k:mutable» «v:native» = NativePtr.read ptr\n\n {\n DirectoryInfo = Option.ofNativePtr DirectoryInfo.ofNativePtr native.directory\n }\n\n «k:let» «f:convertFrom_fs_searchpaths» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») =\n «k:let» «k:rec» «f:f» («v:searchPaths»: «t:SearchPath list») («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») =\n «k:match» NativePtr.isValid ptr «k:with»\n «:fsharp-ui-operator-face:|» «k:false» -> searchPaths\n «:fsharp-ui-operator-face:|» _ ->\n «k:let» «k:mutable» «v:native» = NativePtr.read ptr\n f (ofNativePtr ptr :: searchPaths) (native.next)\n\n f [] ptr\n" }, { "path": "test/apps/FSharp.Compatibility/Format.fs", "content": "(* OCaml Compatibility Library for F# (Format module)\n (FSharp.Compatibility.OCaml.Format)\n\n Copyright (c) 1996 Institut National de Recherche en \n Informatique et en Automatique\n Copyright (c) Jack Pappas 2012\n http://github.com/jack-pappas\n\n This code is distributed under the terms of the\n GNU Lesser General Public License (LGPL) v2.1.\n See the LICENSE file for details. *)\n\n// References:\n// http://caml.inria.fr/pub/docs/manual-ocaml/libref/Format.html\n\n/// Pretty printing.\n[]\nmodule FSharp.Compatibility.OCaml.Format\n\n(**************************************************************\n\n Data structures definitions.\n\n **************************************************************)\n// TODO : Recreate 'size' as a measure type on int\ntype size = int\nlet inline size_of_int (n : int) : size = n\nlet inline int_of_size (s : size) : int = s\n \n(* Tokens are one of the following : *)\ntype pp_token =\n (* normal text *)\n | Pp_text of string\n (* complete break *)\n | Pp_break of int * int\n (* go to next tabulation *)\n | Pp_tbreak of int * int\n (* set a tabulation *)\n | Pp_stab\n (* beginning of a block *)\n | Pp_begin of int * block_type\n (* end of a block *)\n | Pp_end\n (* beginning of a tabulation block *)\n | Pp_tbegin of tblock\n (* end of a tabulation block *)\n | Pp_tend\n (* to force a newline inside a block *)\n | Pp_newline\n (* to do something only if this very line has been broken *)\n | Pp_if_newline\n (* opening a tag name *)\n | Pp_open_tag of tag\n (* closing the most recently opened tag *)\n | Pp_close_tag\n\nand tag = string\n\nand block_type =\n (* Horizontal block no line breaking *)\n | Pp_hbox\n (* Vertical block each break leads to a new line *)\n | Pp_vbox\n (* Horizontal-vertical block: same as vbox, except if this block\n is small enough to fit on a single line *)\n | Pp_hvbox\n (* Horizontal or Vertical block: breaks lead to new line\n only when necessary to print the content of the block *)\n | Pp_hovbox\n (* Horizontal or Indent block: breaks lead to new line\n only when necessary to print the content of the block, or\n when it leads to a new indentation of the current line *)\n | Pp_box\n (* Internal usage: when a block fits on a single line *)\n | Pp_fits\n\nand tblock =\n (* Tabulation box *)\n | Pp_tbox of (int list) ref\n\n(* The Queue:\n contains all formatting elements.\n elements are tuples (size, token, length), where\n size is set when the size of the block is known\n len is the declared length of the token. *)\ntype pp_queue_elem = {\n mutable elem_size : size;\n token : pp_token;\n length : int;\n}\n\n(* Scan stack:\n each element is (left_total, queue element) where left_total\n is the value of pp_left_total when the element has been enqueued. *)\ntype pp_scan_elem =\n | Scan_elem of int * pp_queue_elem\n\n(* Formatting stack:\n used to break the lines while printing tokens.\n The formatting stack contains the description of\n the currently active blocks. *)\ntype pp_format_elem =\n | Format_elem of block_type * int\n\n(* General purpose queues, used in the formatter. *)\ntype 'a queue_elem =\n | Nil\n | Cons of 'a queue_cell\n\nand 'a queue_cell = {\n mutable head : 'a;\n mutable tail : 'a queue_elem;\n}\n\ntype 'a queue = {\n mutable insert : 'a queue_elem;\n mutable body : 'a queue_elem;\n}\n\n(* The formatter specific tag handling functions. *)\ntype formatter_tag_functions = {\n mark_open_tag : tag -> string;\n mark_close_tag : tag -> string;\n print_open_tag : tag -> unit;\n print_close_tag : tag -> unit;\n }\n\n(* A formatter with all its machinery. *)\ntype formatter = {\n mutable pp_scan_stack : pp_scan_elem list;\n mutable pp_format_stack : pp_format_elem list;\n mutable pp_tbox_stack : tblock list;\n mutable pp_tag_stack : tag list;\n mutable pp_mark_stack : tag list;\n (* Global variables: default initialization is\n set_margin 78\n set_min_space_left 0. *)\n /// Value of right margin.\n mutable pp_margin : int;\n /// Minimal space left before margin, when opening a block.\n mutable pp_min_space_left : int;\n /// Maximum value of indentation: no blocks can be opened further.\n mutable pp_max_indent : int;\n /// Space remaining on the current line.\n mutable pp_space_left : int;\n /// Current value of indentation.\n mutable pp_current_indent : int;\n /// True when the line has been broken by the pretty-printer.\n mutable pp_is_new_line : bool;\n /// Total width of tokens already printed.\n mutable pp_left_total : int;\n /// Total width of tokens ever put in queue.\n mutable pp_right_total : int;\n /// Current number of opened blocks.\n mutable pp_curr_depth : int;\n /// Maximum number of blocks which can be simultaneously opened.\n mutable pp_max_boxes : int;\n /// Ellipsis string.\n mutable pp_ellipsis : string;\n /// Output function.\n mutable pp_out_string : string -> int -> int -> unit;\n /// Flushing function.\n mutable pp_out_flush : unit -> unit;\n /// Output of new lines.\n mutable pp_out_newline : unit -> unit;\n /// Output of indentation spaces.\n mutable pp_out_spaces : int -> unit;\n /// Are tags printed?\n mutable pp_print_tags : bool;\n /// Are tags marked?\n mutable pp_mark_tags : bool;\n /// Find opening and closing markers of tags.\n mutable pp_mark_open_tag : tag -> string;\n mutable pp_mark_close_tag : tag -> string;\n mutable pp_print_open_tag : tag -> unit;\n mutable pp_print_close_tag : tag -> unit;\n /// The pretty-printer queue.\n mutable pp_queue : pp_queue_elem queue\n }\n\n(**************************************************************\n\n Auxilliaries and basic functions.\n\n **************************************************************)\n/// Queues auxilliaries.\nlet make_queue () = { insert = Nil; body = Nil; }\n \nlet clear_queue q =\n q.insert <- Nil\n q.body <- Nil\n \nlet add_queue x q =\n let c = Cons { head = x; tail = Nil; }\n match q with\n | { insert = Cons cell; body = _ } ->\n (q.insert <- c; cell.tail <- c)\n | (* Invariant: when insert is Nil body should be Nil. *)\n { insert = Nil; body = _ } -> (q.insert <- c; q.body <- c)\n \nexception Empty_queue\n \nlet peek_queue =\n function\n | { body = Cons { head = x; tail = _ }; insert = _ } -> x\n | { body = Nil; insert = _ } -> raise Empty_queue\n \nlet take_queue =\n function\n | ({ body = Cons { head = x; tail = tl }; insert = _ } as q) ->\n (q.body <- tl;\n if tl = Nil then q.insert <- Nil else ();\n (* Maintain the invariant. *)\n x)\n | { body = Nil; insert = _ } -> raise Empty_queue\n \n(* Enter a token in the pretty-printer queue. *)\nlet pp_enqueue state (({ length = len; elem_size = _; token = _ } as token)) =\n state.pp_right_total <- state.pp_right_total + len\n add_queue token state.pp_queue\n \nlet pp_clear_queue state =\n state.pp_left_total <- 1\n state.pp_right_total <- 1\n clear_queue state.pp_queue\n \n(* Pp_infinity: large value for default tokens size.\n\n Pp_infinity is documented as being greater than 1e10; to avoid\n confusion about the word ``greater'', we choose pp_infinity greater\n than 1e10 + 1; for correct handling of tests in the algorithm,\n pp_infinity must be even one more than 1e10 + 1; let's stand on the\n safe side by choosing 1.e10+10.\n\n Pp_infinity could probably be 1073741823 that is 2^30 - 1, that is\n the minimal upper bound for integers; now that max_int is defined,\n this limit could also be defined as max_int - 1.\n\n However, before setting pp_infinity to something around max_int, we\n must carefully double-check all the integer arithmetic operations\n that involve pp_infinity, since any overflow would wreck havoc the\n pretty-printing algorithm's invariants. Given that this arithmetic\n correctness check is difficult and error prone and given that 1e10\n + 1 is in practice large enough, there is no need to attempt to set\n pp_infinity to the theoretically maximum limit. It is not worth the\n burden ! *)\nlet pp_infinity = 1000000010\n \n(* Output functions for the formatter. *)\nlet rec pp_output_string state s = state.pp_out_string s 0 (String.length s)\nand pp_output_newline state = state.pp_out_newline ()\nand pp_output_spaces state n = state.pp_out_spaces n\n \n(* To format a break, indenting a new line. *)\nlet break_new_line state offset width =\n (pp_output_newline state;\n state.pp_is_new_line <- true;\n let indent = (state.pp_margin - width) + offset in\n (* Don't indent more than pp_max_indent. *)\n let real_indent = min state.pp_max_indent indent\n in\n (state.pp_current_indent <- real_indent;\n state.pp_space_left <- state.pp_margin - state.pp_current_indent;\n pp_output_spaces state state.pp_current_indent))\n \n(* To force a line break inside a block: no offset is added. *)\nlet break_line state width = break_new_line state 0 width\n \n(* To format a break that fits on the current line. *)\nlet break_same_line state width =\n (state.pp_space_left <- state.pp_space_left - width;\n pp_output_spaces state width)\n \n(* To indent no more than pp_max_indent, if one tries to open a block\n beyond pp_max_indent, then the block is rejected on the left\n by simulating a break. *)\nlet pp_force_break_line state =\n match state.pp_format_stack with\n | Format_elem (bl_ty, width) :: _ ->\n if width > state.pp_space_left\n then\n (match bl_ty with\n | Pp_fits -> ()\n | Pp_hbox -> ()\n | Pp_vbox | Pp_hvbox | Pp_hovbox | Pp_box -> break_line state width)\n else ()\n | [] -> pp_output_newline state\n \n(* To skip a token, if the previous line has been broken. *)\nlet pp_skip_token state =\n (* When calling pp_skip_token the queue cannot be empty. *)\n match take_queue state.pp_queue with\n | { elem_size = size; length = len; token = _ } ->\n (state.pp_left_total <- state.pp_left_total - len;\n state.pp_space_left <- state.pp_space_left + (int_of_size size))\n \n(**************************************************************\n\n The main pretty printing functions.\n\n **************************************************************)\n(* To format a token. *)\nlet format_pp_token state size =\n function\n | Pp_text s ->\n (state.pp_space_left <- state.pp_space_left - size;\n pp_output_string state s;\n state.pp_is_new_line <- false)\n | Pp_begin (off, ty) ->\n let insertion_point = state.pp_margin - state.pp_space_left\n in\n (if insertion_point > state.pp_max_indent\n then (* can't open a block right there. *) pp_force_break_line state\n else ();\n let offset = state.pp_space_left - off in\n let bl_type =\n (match ty with\n | Pp_vbox -> Pp_vbox\n | Pp_hbox | Pp_hvbox | Pp_hovbox | Pp_box | Pp_fits ->\n if size > state.pp_space_left then ty else Pp_fits)\n in\n state.pp_format_stack <-\n (Format_elem (bl_type, offset)) :: state.pp_format_stack)\n | Pp_end ->\n (match state.pp_format_stack with\n | _ :: ls -> state.pp_format_stack <- ls\n | [] -> ())\n | (* No more block to close. *) Pp_tbegin ((Pp_tbox _ as tbox)) ->\n state.pp_tbox_stack <- tbox :: state.pp_tbox_stack\n | Pp_tend ->\n (match state.pp_tbox_stack with\n | _ :: ls -> state.pp_tbox_stack <- ls\n | [] -> ())\n | (* No more tabulation block to close. *) Pp_stab ->\n (match state.pp_tbox_stack with\n | Pp_tbox tabs :: _ ->\n let rec add_tab n =\n (function\n | [] -> [ n ]\n | (x :: l as ls) ->\n if n < x then n :: ls else x :: (add_tab n l))\n in tabs := add_tab (state.pp_margin - state.pp_space_left) !tabs\n | [] -> ())\n | (* No opened tabulation block. *) Pp_tbreak (n, off) ->\n let insertion_point = state.pp_margin - state.pp_space_left\n in\n (match state.pp_tbox_stack with\n | Pp_tbox tabs :: _ ->\n let rec find n =\n (function\n | x :: l -> if x >= n then x else find n l\n | [] -> raise Not_found) in\n let tab =\n (match !tabs with\n | x :: _ ->\n (try find insertion_point !tabs with | Not_found -> x)\n | _ -> insertion_point) in\n let offset = tab - insertion_point\n in\n if offset >= 0\n then break_same_line state (offset + n)\n else break_new_line state (tab + off) state.pp_margin\n | [] -> ())\n | (* No opened tabulation block. *) Pp_newline ->\n (match state.pp_format_stack with\n | Format_elem (_, width) :: _ -> break_line state width\n | [] -> pp_output_newline state)\n | (* No opened block. *) Pp_if_newline ->\n if state.pp_current_indent <> (state.pp_margin - state.pp_space_left)\n then pp_skip_token state\n | Pp_break (n, off) ->\n (match state.pp_format_stack with\n | Format_elem (ty, width) :: _ ->\n (match ty with\n | Pp_hovbox ->\n if size > state.pp_space_left\n then break_new_line state off width\n else break_same_line state n\n | Pp_box -> (* Have the line just been broken here ? *)\n if state.pp_is_new_line\n then break_same_line state n\n else\n if size > state.pp_space_left\n then break_new_line state off width\n else (* break the line here leads to new indentation ? *)\n if\n state.pp_current_indent >\n ((state.pp_margin - width) + off)\n then break_new_line state off width\n else break_same_line state n\n | Pp_hvbox -> break_new_line state off width\n | Pp_fits -> break_same_line state n\n | Pp_vbox -> break_new_line state off width\n | Pp_hbox -> break_same_line state n)\n | [] -> ())\n | (* No opened block. *) Pp_open_tag tag_name ->\n let marker = state.pp_mark_open_tag tag_name\n in\n (pp_output_string state marker;\n state.pp_mark_stack <- tag_name :: state.pp_mark_stack)\n | Pp_close_tag ->\n (match state.pp_mark_stack with\n | tag_name :: tags ->\n let marker = state.pp_mark_close_tag tag_name\n in (pp_output_string state marker; state.pp_mark_stack <- tags)\n | [] -> ())\n \n(* No more tag to close. *)\n(* Print if token size is known or printing is delayed.\n Size is known when not negative.\n Printing is delayed when the text waiting in the queue requires\n more room to format than exists on the current line.\n\n Note: [advance_loop] must be tail recursive to prevent stack overflows. *)\nlet rec advance_loop state =\n match peek_queue state.pp_queue with\n | { elem_size = size; token = tok; length = len } ->\n let size = int_of_size size\n in\n if\n not\n ((size < 0) &&\n ((state.pp_right_total - state.pp_left_total) <\n state.pp_space_left))\n then\n (ignore (take_queue state.pp_queue);\n format_pp_token state (if size < 0 then pp_infinity else size) tok;\n state.pp_left_total <- len + state.pp_left_total;\n advance_loop state)\n else ()\n \nlet advance_left state = try advance_loop state with | Empty_queue -> ()\n \nlet enqueue_advance state tok = (pp_enqueue state tok; advance_left state)\n \n(* To enqueue a string : try to advance. *)\nlet make_queue_elem size tok len =\n { elem_size = size; token = tok; length = len; }\n \nlet enqueue_string_as state size s =\n let len = int_of_size size\n in enqueue_advance state (make_queue_elem size (Pp_text s) len)\n \nlet enqueue_string state s =\n let len = String.length s in enqueue_string_as state (size_of_int len) s\n \n(* Routines for scan stack\n determine sizes of blocks. *)\n(* The scan_stack is never empty. *)\nlet scan_stack_bottom =\n let q_elem = make_queue_elem (size_of_int (-1)) (Pp_text \"\") 0\n in [ Scan_elem ((-1), q_elem) ]\n \n(* Set size of blocks on scan stack:\n if ty = true then size of break is set else size of block is set;\n in each case pp_scan_stack is popped. *)\nlet clear_scan_stack state = state.pp_scan_stack <- scan_stack_bottom\n \n(* Pattern matching on scan stack is exhaustive,\n since scan_stack is never empty.\n Pattern matching on token in scan stack is also exhaustive,\n since scan_push is used on breaks and opening of boxes. *)\nlet set_size state ty =\n match state.pp_scan_stack with\n | Scan_elem (left_tot,\n (({ elem_size = size; token = tok; length = _ } as queue_elem))) :: t\n ->\n let size = int_of_size size\n in\n (* test if scan stack contains any data that is not obsolete. *)\n if left_tot < state.pp_left_total\n then clear_scan_stack state\n else\n (match tok with\n | Pp_break (_, _) | Pp_tbreak (_, _) ->\n if ty\n then\n (queue_elem.elem_size <-\n size_of_int (state.pp_right_total + size);\n state.pp_scan_stack <- t)\n else ()\n | Pp_begin (_, _) ->\n if not ty\n then\n (queue_elem.elem_size <-\n size_of_int (state.pp_right_total + size);\n state.pp_scan_stack <- t)\n else ()\n | Pp_text _ | Pp_stab | Pp_tbegin _ | Pp_tend | Pp_end |\n Pp_newline | Pp_if_newline | Pp_open_tag _ | Pp_close_tag ->\n ())\n | (* scan_push is only used for breaks and boxes. *) [] -> ()\n \n(* scan_stack is never empty. *)\n(* Push a token on scan stack. If b is true set_size is called. *)\nlet scan_push state b tok =\n (pp_enqueue state tok;\n if b then set_size state true else ();\n state.pp_scan_stack <-\n (Scan_elem (state.pp_right_total, tok)) :: state.pp_scan_stack)\n \n(* To open a new block :\n the user may set the depth bound pp_max_boxes\n any text nested deeper is printed as the ellipsis string. *)\nlet pp_open_box_gen state indent br_ty =\n (state.pp_curr_depth <- state.pp_curr_depth + 1;\n if state.pp_curr_depth < state.pp_max_boxes\n then\n (let elem =\n make_queue_elem (size_of_int (- state.pp_right_total))\n (Pp_begin (indent, br_ty)) 0\n in scan_push state false elem)\n else\n if state.pp_curr_depth = state.pp_max_boxes\n then enqueue_string state state.pp_ellipsis\n else ())\n \n(* The box which is always opened. *)\nlet pp_open_sys_box state = pp_open_box_gen state 0 Pp_hovbox\n \n(* Close a block, setting sizes of its sub blocks. *)\nlet pp_close_box state () =\n if state.pp_curr_depth > 1\n then\n (if state.pp_curr_depth < state.pp_max_boxes\n then\n (pp_enqueue state\n { elem_size = size_of_int 0; token = Pp_end; length = 0; };\n set_size state true;\n set_size state false)\n else ();\n state.pp_curr_depth <- state.pp_curr_depth - 1)\n else ()\n \n(* Open a tag, pushing it on the tag stack. *)\nlet pp_open_tag state tag_name =\n (if state.pp_print_tags\n then\n (state.pp_tag_stack <- tag_name :: state.pp_tag_stack;\n state.pp_print_open_tag tag_name)\n else ();\n if state.pp_mark_tags\n then\n pp_enqueue state\n { elem_size = size_of_int 0; token = Pp_open_tag tag_name; length = 0;\n }\n else ())\n \n(* Close a tag, popping it from the tag stack. *)\nlet pp_close_tag state () =\n (if state.pp_mark_tags\n then\n pp_enqueue state\n { elem_size = size_of_int 0; token = Pp_close_tag; length = 0; }\n else ();\n if state.pp_print_tags\n then\n (match state.pp_tag_stack with\n | tag_name :: tags ->\n (state.pp_print_close_tag tag_name; state.pp_tag_stack <- tags)\n | _ -> ())\n else ())\n \n(* No more tag to close. *)\nlet pp_set_print_tags state b = state.pp_print_tags <- b\n \nlet pp_set_mark_tags state b = state.pp_mark_tags <- b\n \nlet pp_get_print_tags state () = state.pp_print_tags\n \nlet pp_get_mark_tags state () = state.pp_mark_tags\n \nlet pp_set_tags state b =\n (pp_set_print_tags state b; pp_set_mark_tags state b)\n \nlet pp_get_formatter_tag_functions state () =\n {\n mark_open_tag = state.pp_mark_open_tag;\n mark_close_tag = state.pp_mark_close_tag;\n print_open_tag = state.pp_print_open_tag;\n print_close_tag = state.pp_print_close_tag;\n }\n \nlet pp_set_formatter_tag_functions state\n {\n mark_open_tag = mot;\n mark_close_tag = mct;\n print_open_tag = pot;\n print_close_tag = pct\n } =\n (state.pp_mark_open_tag <- mot;\n state.pp_mark_close_tag <- mct;\n state.pp_print_open_tag <- pot;\n state.pp_print_close_tag <- pct)\n \n(* Initialize pretty-printer. *)\nlet pp_rinit state =\n (pp_clear_queue state;\n clear_scan_stack state;\n state.pp_format_stack <- [];\n state.pp_tbox_stack <- [];\n state.pp_tag_stack <- [];\n state.pp_mark_stack <- [];\n state.pp_current_indent <- 0;\n state.pp_curr_depth <- 0;\n state.pp_space_left <- state.pp_margin;\n pp_open_sys_box state)\n \n(* Flushing pretty-printer queue. *)\nlet pp_flush_queue state b =\n (while state.pp_curr_depth > 1 do pp_close_box state () done;\n state.pp_right_total <- pp_infinity;\n advance_left state;\n if b then pp_output_newline state else ();\n pp_rinit state)\n \n(**************************************************************\n\n Procedures to format objects, and use boxes\n\n **************************************************************)\n(* To format a string. *)\nlet pp_print_as_size state size s =\n if state.pp_curr_depth < state.pp_max_boxes\n then enqueue_string_as state size s\n else ()\n \nlet pp_print_as state isize s = pp_print_as_size state (size_of_int isize) s\n \nlet pp_print_string state s = pp_print_as state (String.length s) s\n \n(* To format an integer. *)\nlet pp_print_int state i = pp_print_string state (string_of_int i)\n \n(* To format a float. *)\nlet pp_print_float state f = pp_print_string state (string_of_float f)\n \n(* To format a boolean. *)\nlet pp_print_bool state b = pp_print_string state (string_of_bool b)\n \n(* To format a char. *)\nlet pp_print_char state (c : char) =\n pp_print_as state 1 (string c)\n \n(* Opening boxes. *)\nlet rec pp_open_hbox state () = pp_open_box_gen state 0 Pp_hbox\nand pp_open_vbox state indent = pp_open_box_gen state indent Pp_vbox\nand pp_open_hvbox state indent = pp_open_box_gen state indent Pp_hvbox\nand pp_open_hovbox state indent = pp_open_box_gen state indent Pp_hovbox\nand pp_open_box state indent = pp_open_box_gen state indent Pp_box\n \n(* Print a new line after printing all queued text\n (same for print_flush but without a newline). *)\nlet rec pp_print_newline state () =\n pp_flush_queue state true\n state.pp_out_flush ()\nand pp_print_flush state () =\n pp_flush_queue state false\n state.pp_out_flush ()\n \n(* To get a newline when one does not want to close the current block. *)\nlet pp_force_newline state () =\n if state.pp_curr_depth < state.pp_max_boxes\n then enqueue_advance state (make_queue_elem (size_of_int 0) Pp_newline 0)\n else ()\n \n(* To format something if the line has just been broken. *)\nlet pp_print_if_newline state () =\n if state.pp_curr_depth < state.pp_max_boxes\n then\n enqueue_advance state (make_queue_elem (size_of_int 0) Pp_if_newline 0)\n else ()\n \n(* Breaks: indicate where a block may be broken.\n If line is broken then offset is added to the indentation of the current\n block else (the value of) width blanks are printed.\n To do (?) : add a maximum width and offset value. *)\nlet pp_print_break state width offset =\n if state.pp_curr_depth < state.pp_max_boxes\n then\n (let elem =\n make_queue_elem (size_of_int (- state.pp_right_total))\n (Pp_break (width, offset)) width\n in scan_push state true elem)\n else ()\n \nlet rec pp_print_space state () = pp_print_break state 1 0\nand pp_print_cut state () = pp_print_break state 0 0\n \n(* Tabulation boxes. *)\nlet pp_open_tbox state () =\n (state.pp_curr_depth <- state.pp_curr_depth + 1;\n if state.pp_curr_depth < state.pp_max_boxes\n then\n (let elem =\n make_queue_elem (size_of_int 0) (Pp_tbegin (Pp_tbox (ref []))) 0\n in enqueue_advance state elem)\n else ())\n \n(* Close a tabulation block. *)\nlet pp_close_tbox state () =\n if state.pp_curr_depth > 1\n then\n if state.pp_curr_depth < state.pp_max_boxes\n then\n (let elem = make_queue_elem (size_of_int 0) Pp_tend 0\n in\n (enqueue_advance state elem;\n state.pp_curr_depth <- state.pp_curr_depth - 1))\n else ()\n else ()\n \n(* Print a tabulation break. *)\nlet pp_print_tbreak state width offset =\n if state.pp_curr_depth < state.pp_max_boxes\n then\n (let elem =\n make_queue_elem (size_of_int (- state.pp_right_total))\n (Pp_tbreak (width, offset)) width\n in scan_push state true elem)\n else ()\n \nlet pp_print_tab state () = pp_print_tbreak state 0 0\n \nlet pp_set_tab state () =\n if state.pp_curr_depth < state.pp_max_boxes\n then\n (let elem = make_queue_elem (size_of_int 0) Pp_stab 0\n in enqueue_advance state elem)\n else ()\n \n(**************************************************************\n\n Procedures to control the pretty-printers\n\n **************************************************************)\n(* Fit max_boxes. *)\nlet pp_set_max_boxes state n = if n > 1 then state.pp_max_boxes <- n else ()\n \n(* To know the current maximum number of boxes allowed. *)\nlet pp_get_max_boxes state () = state.pp_max_boxes\n \nlet pp_over_max_boxes state () = state.pp_curr_depth = state.pp_max_boxes\n \n(* Ellipsis. *)\nlet rec pp_set_ellipsis_text state s = state.pp_ellipsis <- s\nand pp_get_ellipsis_text state () = state.pp_ellipsis\n \n(* To set the margin of pretty-printer. *)\nlet pp_limit n = if n < pp_infinity then n else pred pp_infinity\n \nlet pp_set_min_space_left state n =\n if n >= 1\n then\n (let n = pp_limit n\n in\n (state.pp_min_space_left <- n;\n state.pp_max_indent <- state.pp_margin - state.pp_min_space_left;\n pp_rinit state))\n else ()\n \n(* Initially, we have :\n pp_max_indent = pp_margin - pp_min_space_left, and\n pp_space_left = pp_margin. *)\nlet pp_set_max_indent state n =\n pp_set_min_space_left state (state.pp_margin - n)\n \nlet pp_get_max_indent state () = state.pp_max_indent\n \nlet pp_set_margin state n =\n if n >= 1\n then\n (let n = pp_limit n\n in\n (state.pp_margin <- n;\n let new_max_indent =\n (* Try to maintain max_indent to its actual value. *)\n if state.pp_max_indent <= state.pp_margin\n then state.pp_max_indent\n else\n (* If possible maintain pp_min_space_left to its actual value,\n if this leads to a too small max_indent, take half of the\n new margin, if it is greater than 1. *)\n max\n (max (state.pp_margin - state.pp_min_space_left)\n (state.pp_margin / 2))\n 1\n in (* Rebuild invariants. *) pp_set_max_indent state new_max_indent))\n else ()\n \nlet pp_get_margin state () = state.pp_margin\n \ntype formatter_out_functions = {\n out_string : string -> int -> int -> unit;\n out_flush : unit -> unit;\n out_newline : unit -> unit;\n out_spaces : int -> unit\n }\n\nlet pp_set_formatter_out_functions state\n {\n out_string = f;\n out_flush = g;\n out_newline = h;\n out_spaces = i\n } =\n state.pp_out_string <- f\n state.pp_out_flush <- g\n state.pp_out_newline <- h\n state.pp_out_spaces <- i\n \nlet pp_get_formatter_out_functions state () =\n {\n out_string = state.pp_out_string;\n out_flush = state.pp_out_flush;\n out_newline = state.pp_out_newline;\n out_spaces = state.pp_out_spaces;\n }\n \nlet pp_set_formatter_output_functions state f g =\n (state.pp_out_string <- f; state.pp_out_flush <- g)\n \nlet pp_get_formatter_output_functions state () =\n state.pp_out_string, state.pp_out_flush\n \n//let pp_set_all_formatter_output_functions state ~out:f ~flush:g ~newline:h ~spaces:i =\nlet pp_set_all_formatter_output_functions state f g h i =\n pp_set_formatter_output_functions state f g\n state.pp_out_newline <- h\n state.pp_out_spaces <- i\n \nlet pp_get_all_formatter_output_functions state () =\n state.pp_out_string,\n state.pp_out_flush,\n state.pp_out_newline,\n state.pp_out_spaces\n \n(* Default function to output new lines. *)\nlet display_newline state () = state.pp_out_string \"\\n\" 0 1\n \n(* Default function to output spaces. *)\nlet blank_line = String.make 80 ' '\n \nlet rec display_blanks state n =\n if n > 0 then\n if n <= 80\n then state.pp_out_string blank_line 0 n\n else (state.pp_out_string blank_line 0 80; display_blanks state (n - 80))\n \n/// Re-implementation of OCaml's Pervasives.output, since the one in the\n/// F# compatibility library doesn't have the right type signature.\nlet private output oc (buf : string) (pos : int) (len : int) =\n output_string oc (buf.Substring (pos, len))\n\nlet pp_set_formatter_out_channel state os =\n state.pp_out_string <- output os\n state.pp_out_flush <- (fun () -> flush os)\n state.pp_out_newline <- display_newline state\n state.pp_out_spaces <- display_blanks state\n \n(**************************************************************\n\n Creation of specific formatters\n\n **************************************************************)\nlet default_pp_mark_open_tag s = \"<\" ^ (s ^ \">\")\n \nlet default_pp_mark_close_tag s = \"\")\n \nlet default_pp_print_open_tag = ignore\n \nlet default_pp_print_close_tag = ignore\n \nlet pp_make_formatter f g h i =\n (* The initial state of the formatter contains a dummy box. *)\n let pp_q = make_queue () in\n let sys_tok =\n make_queue_elem (size_of_int (-1)) (Pp_begin (0, Pp_hovbox)) 0\n in\n (add_queue sys_tok pp_q;\n let sys_scan_stack = (Scan_elem (1, sys_tok)) :: scan_stack_bottom\n in\n {\n pp_scan_stack = sys_scan_stack;\n pp_format_stack = [];\n pp_tbox_stack = [];\n pp_tag_stack = [];\n pp_mark_stack = [];\n pp_margin = 78;\n pp_min_space_left = 10;\n pp_max_indent = 78 - 10;\n pp_space_left = 78;\n pp_current_indent = 0;\n pp_is_new_line = true;\n pp_left_total = 1;\n pp_right_total = 1;\n pp_curr_depth = 1;\n pp_max_boxes = max_int;\n pp_ellipsis = \".\";\n pp_out_string = f;\n pp_out_flush = g;\n pp_out_newline = h;\n pp_out_spaces = i;\n pp_print_tags = false;\n pp_mark_tags = false;\n pp_mark_open_tag = default_pp_mark_open_tag;\n pp_mark_close_tag = default_pp_mark_close_tag;\n pp_print_open_tag = default_pp_print_open_tag;\n pp_print_close_tag = default_pp_print_close_tag;\n pp_queue = pp_q;\n })\n \n(* Make a formatter with default functions to output spaces and new lines. *)\nlet make_formatter output flush =\n let ppf = pp_make_formatter output flush ignore ignore\n in\n (ppf.pp_out_newline <- display_newline ppf;\n ppf.pp_out_spaces <- display_blanks ppf;\n ppf)\n \nlet formatter_of_out_channel oc =\n make_formatter (output oc) (fun () -> flush oc)\n \nlet formatter_of_buffer b = make_formatter (Buffer.add_substring b) ignore\n \nlet stdbuf = Buffer.create 512\n \n(* Predefined formatters. *)\nlet rec std_formatter = formatter_of_out_channel Pervasives.stdout\nand err_formatter = formatter_of_out_channel Pervasives.stderr\nand str_formatter = formatter_of_buffer stdbuf\n \nlet flush_str_formatter () =\n (pp_flush_queue str_formatter false;\n let s = Buffer.contents stdbuf in (Buffer.reset stdbuf; s))\n \n(**************************************************************\n\n Basic functions on the standard formatter\n\n **************************************************************)\nlet rec open_hbox = pp_open_hbox std_formatter\nand open_vbox = pp_open_vbox std_formatter\nand open_hvbox = pp_open_hvbox std_formatter\nand open_hovbox = pp_open_hovbox std_formatter\nand open_box = pp_open_box std_formatter\nand close_box = pp_close_box std_formatter\nand open_tag = pp_open_tag std_formatter\nand close_tag = pp_close_tag std_formatter\nand print_as = pp_print_as std_formatter\nand print_string = pp_print_string std_formatter\nand print_int = pp_print_int std_formatter\nand print_float = pp_print_float std_formatter\nand print_char = pp_print_char std_formatter\nand print_bool = pp_print_bool std_formatter\nand print_break = pp_print_break std_formatter\nand print_cut = pp_print_cut std_formatter\nand print_space = pp_print_space std_formatter\nand force_newline = pp_force_newline std_formatter\nand print_flush = pp_print_flush std_formatter\nand print_newline = pp_print_newline std_formatter\nand print_if_newline = pp_print_if_newline std_formatter\nand open_tbox = pp_open_tbox std_formatter\nand close_tbox = pp_close_tbox std_formatter\nand print_tbreak = pp_print_tbreak std_formatter\nand set_tab = pp_set_tab std_formatter\nand print_tab = pp_print_tab std_formatter\nand set_margin = pp_set_margin std_formatter\nand get_margin = pp_get_margin std_formatter\nand set_max_indent = pp_set_max_indent std_formatter\nand get_max_indent = pp_get_max_indent std_formatter\nand set_max_boxes = pp_set_max_boxes std_formatter\nand get_max_boxes = pp_get_max_boxes std_formatter\nand over_max_boxes = pp_over_max_boxes std_formatter\nand set_ellipsis_text = pp_set_ellipsis_text std_formatter\nand get_ellipsis_text = pp_get_ellipsis_text std_formatter\nand set_formatter_out_channel (channel : out_channel) =\n pp_set_formatter_out_channel std_formatter channel\nand set_formatter_out_functions =\n pp_set_formatter_out_functions std_formatter\nand get_formatter_out_functions =\n pp_get_formatter_out_functions std_formatter\nand set_formatter_output_functions =\n pp_set_formatter_output_functions std_formatter\nand get_formatter_output_functions =\n pp_get_formatter_output_functions std_formatter\nand set_all_formatter_output_functions =\n pp_set_all_formatter_output_functions std_formatter\nand get_all_formatter_output_functions =\n pp_get_all_formatter_output_functions std_formatter\nand set_formatter_tag_functions =\n pp_set_formatter_tag_functions std_formatter\nand get_formatter_tag_functions =\n pp_get_formatter_tag_functions std_formatter\nand set_print_tags = pp_set_print_tags std_formatter\nand get_print_tags = pp_get_print_tags std_formatter\nand set_mark_tags = pp_set_mark_tags std_formatter\nand get_mark_tags = pp_get_mark_tags std_formatter\nand set_tags = pp_set_tags std_formatter\n \n(**************************************************************\n\n Printf implementation.\n\n **************************************************************)\nmodule Sformat = Printf.Sformat\n \nmodule Tformat = Printf.CamlinternalPr.Tformat\n \n(* Error messages when processing formats. *)\n(* Trailer: giving up at character number ... *)\nlet giving_up mess fmt i =\n sprintf \"Format.fprintf: %s ``%s'', giving up at character number %d%s\"\n mess (Sformat.to_string fmt) i\n (if i < Sformat.length fmt\n then sprintf \" (%c).\" (Sformat.get fmt i)\n else sprintf \"%c\" '.')\n \n(* When an invalid format deserves a special error explanation. *)\nlet format_invalid_arg mess fmt i = invalid_arg (giving_up mess fmt i)\n \n(* Standard invalid format. *)\nlet invalid_format fmt i = format_invalid_arg \"bad format\" fmt i\n \n(* Cannot find a valid integer into that format. *)\nlet invalid_integer fmt i =\n invalid_arg (giving_up \"bad integer specification\" fmt i)\n \n(* Finding an integer size out of a sub-string of the format. *)\nlet format_int_of_string fmt i s =\n let sz = try int_of_string s with | Failure _ -> invalid_integer fmt i\n in size_of_int sz\n \n(* Getting strings out of buffers. *)\nlet get_buffer_out b = let s = Buffer.contents b in (Buffer.reset b; s)\n \n(* [ppf] is supposed to be a pretty-printer that outputs to buffer [b]:\n to extract the contents of [ppf] as a string we flush [ppf] and get the\n string out of [b]. *)\nlet string_out b ppf = (pp_flush_queue ppf false; get_buffer_out b)\n \n(* Applies [printer] to a formatter that outputs on a fresh buffer,\n then returns the resulting material. *)\nlet exstring printer arg =\n let b = Buffer.create 512 in\n let ppf = formatter_of_buffer b in (printer ppf arg; string_out b ppf)\n \n(* To turn out a character accumulator into the proper string result. *)\nlet implode_rev s0 = function\n | [] -> s0\n | l -> String.concat \"\" (List.rev (s0 :: l))\n \n(* [mkprintf] is the printf-like function generator: given the\n - [to_s] flag that tells if we are printing into a string,\n - the [get_out] function that has to be called to get a [ppf] function to\n output onto,\n it generates a [kprintf] function that takes as arguments a [k]\n continuation function to be called at the end of formatting,\n and a printing format string to print the rest of the arguments\n according to the format string.\n Regular [fprintf]-like functions of this module are obtained via partial\n applications of [mkprintf]. *)\nlet mkprintf to_s get_out =\n let rec kprintf k fmt =\n let len = Sformat.length fmt in\n let kpr fmt v =\n let ppf = get_out fmt in\n let print_as = ref None in\n let rec pp_print_as_char c =\n match !print_as with\n | None -> pp_print_char ppf c\n | Some size ->\n (pp_print_as_size ppf size (String.make 1 c); print_as := None)\n and pp_print_as_string s =\n match !print_as with\n | None -> pp_print_string ppf s\n | Some size -> (pp_print_as_size ppf size s; print_as := None) in\n let rec doprn n i =\n if i >= len\n then Obj.magic (k ppf)\n else\n (match Sformat.get fmt i with\n | '%' ->\n Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f\n cont_m\n | '@' ->\n let i = succ i\n in\n if i >= len\n then invalid_format fmt i\n else\n (match Sformat.get fmt i with\n | '[' -> do_pp_open_box ppf n (succ i)\n | ']' -> (pp_close_box ppf (); doprn n (succ i))\n | '{' -> do_pp_open_tag ppf n (succ i)\n | '}' -> (pp_close_tag ppf (); doprn n (succ i))\n | ' ' -> (pp_print_space ppf (); doprn n (succ i))\n | ',' -> (pp_print_cut ppf (); doprn n (succ i))\n | '?' -> (pp_print_flush ppf (); doprn n (succ i))\n | '.' -> (pp_print_newline ppf (); doprn n (succ i))\n | '\\n' -> (pp_force_newline ppf (); doprn n (succ i))\n | ';' -> do_pp_break ppf n (succ i)\n | '<' ->\n let got_size size n i =\n (print_as := Some size; doprn n (skip_gt i))\n in get_int n (succ i) got_size\n | ('@' | '%' as c) ->\n (pp_print_as_char c; doprn n (succ i))\n | _ -> invalid_format fmt i)\n | c -> (pp_print_as_char c; doprn n (succ i)))\n and cont_s n s i = (pp_print_as_string s; doprn n i)\n and cont_a n printer arg i =\n (if to_s\n then\n pp_print_as_string\n ((Obj.magic printer : unit -> _ -> string) () arg)\n else printer ppf arg;\n doprn n i)\n and cont_t n printer i =\n (if to_s\n then pp_print_as_string ((Obj.magic printer : unit -> string) ())\n else printer ppf;\n doprn n i)\n and cont_f n i = (pp_print_flush ppf (); doprn n i)\n and cont_m n sfmt i = kprintf (Obj.magic (fun _ -> doprn n i)) sfmt\n and get_int n i c =\n if i >= len\n then invalid_integer fmt i\n else\n (match Sformat.get fmt i with\n | ' ' -> get_int n (succ i) c\n | '%' ->\n let rec cont_s n s i = c (format_int_of_string fmt i s) n i\n and cont_a _n _printer _arg i = invalid_integer fmt i\n and cont_t _n _printer i = invalid_integer fmt i\n and cont_f _n i = invalid_integer fmt i\n and cont_m _n _sfmt i = invalid_integer fmt i\n in\n Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f\n cont_m\n | _ ->\n let rec get j =\n if j >= len\n then invalid_integer fmt j\n else\n (match Sformat.get fmt j with\n | x when x >= '0' && x <= '9' ->\n get (succ j)\n | '-' -> get (succ j)\n | _ ->\n let size =\n if j = i\n then size_of_int 0\n else\n (let s =\n Sformat.sub fmt (Sformat.index_of_int i)\n (j - i)\n in format_int_of_string fmt j s)\n in c size n j)\n in get i)\n and skip_gt i =\n if i >= len\n then invalid_format fmt i\n else\n (match Sformat.get fmt i with\n | ' ' -> skip_gt (succ i)\n | '>' -> succ i\n | _ -> invalid_format fmt i)\n and get_box_kind i =\n if i >= len\n then (Pp_box, i)\n else\n (match Sformat.get fmt i with\n | 'h' ->\n let i = succ i\n in\n if i >= len\n then (Pp_hbox, i)\n else\n (match Sformat.get fmt i with\n | 'o' ->\n let i = succ i\n in\n if i >= len\n then format_invalid_arg \"bad box format\" fmt i\n else\n (match Sformat.get fmt i with\n | 'v' -> (Pp_hovbox, (succ i))\n | c ->\n format_invalid_arg\n (\"bad box name ho\" ^ (String.make 1 c))\n fmt i)\n | 'v' -> (Pp_hvbox, (succ i))\n | _ -> (Pp_hbox, i))\n | 'b' -> (Pp_box, (succ i))\n | 'v' -> (Pp_vbox, (succ i))\n | _ -> (Pp_box, i))\n and get_tag_name n i c =\n let rec get accu n i j =\n if j >= len\n then\n c\n (implode_rev (Sformat.sub fmt (Sformat.index_of_int i) (j - i))\n accu)\n n j\n else\n (match Sformat.get fmt j with\n | '>' ->\n c\n (implode_rev\n (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) accu)\n n j\n | '%' ->\n let s0 = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in\n let rec cont_s n s i = get (s :: s0 :: accu) n i i\n and cont_a n printer arg i =\n let s =\n if to_s\n then (Obj.magic printer : unit -> _ -> string) () arg\n else exstring printer arg\n in get (s :: s0 :: accu) n i i\n and cont_t n printer i =\n let s =\n if to_s\n then (Obj.magic printer : unit -> string) ()\n else exstring (fun ppf () -> printer ppf) ()\n in get (s :: s0 :: accu) n i i\n and cont_f _n i =\n format_invalid_arg \"bad tag name specification\" fmt i\n and cont_m _n _sfmt i =\n format_invalid_arg \"bad tag name specification\" fmt i\n in\n Tformat.scan_format fmt v n j cont_s cont_a cont_t cont_f\n cont_m\n | _ -> get accu n i (succ j))\n in get [] n i i\n and do_pp_break ppf n i =\n if i >= len\n then (pp_print_space ppf (); doprn n i)\n else\n (match Sformat.get fmt i with\n | '<' ->\n let rec got_nspaces nspaces n i =\n get_int n i (got_offset nspaces)\n and got_offset nspaces offset n i =\n (pp_print_break ppf (int_of_size nspaces)\n (int_of_size offset);\n doprn n (skip_gt i))\n in get_int n (succ i) got_nspaces\n | _c -> (pp_print_space ppf (); doprn n i))\n and do_pp_open_box ppf n i =\n if i >= len\n then (pp_open_box_gen ppf 0 Pp_box; doprn n i)\n else\n (match Sformat.get fmt i with\n | '<' ->\n let (kind, i) = get_box_kind (succ i) in\n let got_size size n i =\n (pp_open_box_gen ppf (int_of_size size) kind;\n doprn n (skip_gt i))\n in get_int n i got_size\n | _c -> (pp_open_box_gen ppf 0 Pp_box; doprn n i))\n and do_pp_open_tag ppf n i =\n if i >= len\n then (pp_open_tag ppf \"\"; doprn n i)\n else\n (match Sformat.get fmt i with\n | '<' ->\n let got_name tag_name n i =\n (pp_open_tag ppf tag_name; doprn n (skip_gt i))\n in get_tag_name n (succ i) got_name\n | _c -> (pp_open_tag ppf \"\"; doprn n i))\n in doprn (Sformat.index_of_int 0) 0\n in Tformat.kapr kpr fmt\n in kprintf\n \n(**************************************************************\n\n Defining [fprintf] and various flavors of [fprintf].\n\n **************************************************************)\nlet kfprintf k ppf = mkprintf false (fun _ -> ppf) k\n \nlet ikfprintf k ppf = Tformat.kapr (fun _ _ -> Obj.magic (k ppf))\n \nlet fprintf ppf = kfprintf ignore ppf\n \nlet ifprintf ppf = ikfprintf ignore ppf\n \nlet printf fmt = fprintf std_formatter fmt\n \nlet eprintf fmt = fprintf err_formatter fmt\n \nlet ksprintf k =\n let b = Buffer.create 512 in\n let k ppf = k (string_out b ppf)\n in mkprintf true (fun _ -> formatter_of_buffer b) k\n \nlet sprintf fmt = ksprintf (fun s -> s) fmt\n \n(**************************************************************\n\n Deprecated stuff.\n\n **************************************************************)\nlet kbprintf k b = mkprintf false (fun _ -> formatter_of_buffer b) k\n \n(* Deprecated error prone function bprintf. *)\nlet bprintf b = let k ppf = pp_flush_queue ppf false in kbprintf k b\n \n(* Deprecated alias for ksprintf. *)\nlet kprintf = ksprintf\n \n(* Output everything left in the pretty printer queue at end of execution. *)\nlet _ = at_exit print_flush\n \n" }, { "path": "test/apps/FSharp.Compatibility/Format.fs.faceup", "content": "«x:(* OCaml Compatibility Library for F# (Format module)\n (FSharp.Compatibility.OCaml.Format)\n\n Copyright (c) 1996 Institut National de Recherche en \n Informatique et en Automatique\n Copyright (c) Jack Pappas 2012\n http://github.com/jack-pappas\n\n This code is distributed under the terms of the\n GNU Lesser General Public License (LGPL) v2.1.\n See the LICENSE file for details. *)»\n\n«m:// »«x:References:\n»«m:// »«x:http://caml.inria.fr/pub/docs/manual-ocaml/libref/Format.html\n»\n«m:/// »«x:Pretty printing.\n»[]\n«k:module» «t:FSharp.Compatibility.OCaml.Format»\n\n«x:(**************************************************************\n\n Data structures definitions.\n\n **************************************************************)»\n«m:// »«x:TODO : Recreate 'size' as a measure type on int\n»«k:type» «t:size» = int\n«k:let» «k:inline» «f:size_of_int» («v:n» : «t:int») : «t:size» = n\n«k:let» «k:inline» «f:int_of_size» («v:s» : «t:size») : «t:int» = s\n \n«x:(* Tokens are one of the following : *)»\n«k:type» «t:pp_token» =\n «x:(* normal text *)»\n «:fsharp-ui-operator-face:|» Pp_text «k:of» string\n «x:(* complete break *)»\n «:fsharp-ui-operator-face:|» Pp_break «k:of» int * int\n «x:(* go to next tabulation *)»\n «:fsharp-ui-operator-face:|» Pp_tbreak «k:of» int * int\n «x:(* set a tabulation *)»\n «:fsharp-ui-operator-face:|» Pp_stab\n «x:(* beginning of a block *)»\n «:fsharp-ui-operator-face:|» Pp_begin «k:of» int * block_type\n «x:(* end of a block *)»\n «:fsharp-ui-operator-face:|» Pp_end\n «x:(* beginning of a tabulation block *)»\n «:fsharp-ui-operator-face:|» Pp_tbegin «k:of» tblock\n «x:(* end of a tabulation block *)»\n «:fsharp-ui-operator-face:|» Pp_tend\n «x:(* to force a newline inside a block *)»\n «:fsharp-ui-operator-face:|» Pp_newline\n «x:(* to do something only if this very line has been broken *)»\n «:fsharp-ui-operator-face:|» Pp_if_newline\n «x:(* opening a tag name *)»\n «:fsharp-ui-operator-face:|» Pp_open_tag «k:of» tag\n «x:(* closing the most recently opened tag *)»\n «:fsharp-ui-operator-face:|» Pp_close_tag\n\n«k:and» «v:tag» = string\n\n«k:and» «v:block_type» =\n «x:(* Horizontal block no line breaking *)»\n «:fsharp-ui-operator-face:|» Pp_hbox\n «x:(* Vertical block each break leads to a new line *)»\n «:fsharp-ui-operator-face:|» Pp_vbox\n «x:(* Horizontal-vertical block: same as vbox, except if this block\n is small enough to fit on a single line *)»\n «:fsharp-ui-operator-face:|» Pp_hvbox\n «x:(* Horizontal or Vertical block: breaks lead to new line\n only when necessary to print the content of the block *)»\n «:fsharp-ui-operator-face:|» Pp_hovbox\n «x:(* Horizontal or Indent block: breaks lead to new line\n only when necessary to print the content of the block, or\n when it leads to a new indentation of the current line *)»\n «:fsharp-ui-operator-face:|» Pp_box\n «x:(* Internal usage: when a block fits on a single line *)»\n «:fsharp-ui-operator-face:|» Pp_fits\n\n«k:and» «v:tblock» =\n «x:(* Tabulation box *)»\n «:fsharp-ui-operator-face:|» Pp_tbox «k:of» (int list) ref\n\n«x:(* The Queue:\n contains all formatting elements.\n elements are tuples (size, token, length), where\n size is set when the size of the block is known\n len is the declared length of the token. *)»\n«k:type» «t:pp_queue_elem» = {\n «k:mutable» elem_size : «t:size»;\n token : «t:pp_token»;\n length : «t:int»;\n}\n\n«x:(* Scan stack:\n each element is (left_total, queue element) where left_total\n is the value of pp_left_total when the element has been enqueued. *)»\n«k:type» «t:pp_scan_elem» =\n «:fsharp-ui-operator-face:|» Scan_elem «k:of» int * pp_queue_elem\n\n«x:(* Formatting stack:\n used to break the lines while printing tokens.\n The formatting stack contains the description of\n the currently active blocks. *)»\n«k:type» «t:pp_format_elem» =\n «:fsharp-ui-operator-face:|» Format_elem «k:of» block_type * int\n\n«x:(* General purpose queues, used in the formatter. *)»\n«k:type» «t:'a» «v:queue_elem» =\n «:fsharp-ui-operator-face:|» Nil\n «:fsharp-ui-operator-face:|» Cons «k:of» 'a queue_cell\n\n«k:and» «f:'a» «v:queue_cell» = {\n «k:mutable» head : 'a;\n «k:mutable» tail : 'a queue_elem;\n}\n\n«k:type» «t:'a» «v:queue» = {\n «k:mutable» insert : 'a queue_elem;\n «k:mutable» body : 'a queue_elem;\n}\n\n«x:(* The formatter specific tag handling functions. *)»\n«k:type» «t:formatter_tag_functions» = {\n mark_open_tag : «t:tag» -> string;\n mark_close_tag : «t:tag» -> string;\n print_open_tag : «t:tag» -> unit;\n print_close_tag : «t:tag» -> unit;\n }\n\n«x:(* A formatter with all its machinery. *)»\n«k:type» «t:formatter» = {\n «k:mutable» pp_scan_stack : «t:pp_scan_elem list»;\n «k:mutable» pp_format_stack : «t:pp_format_elem list»;\n «k:mutable» pp_tbox_stack : «t:tblock list»;\n «k:mutable» pp_tag_stack : «t:tag list»;\n «k:mutable» pp_mark_stack : «t:tag list»;\n «x:(* Global variables: default initialization is\n set_margin 78\n set_min_space_left 0. *)»\n «m:/// »«x:Value of right margin.\n» «k:mutable» pp_margin : «t:int»;\n «m:/// »«x:Minimal space left before margin, when opening a block.\n» «k:mutable» pp_min_space_left : «t:int»;\n «m:/// »«x:Maximum value of indentation: no blocks can be opened further.\n» «k:mutable» pp_max_indent : «t:int»;\n «m:/// »«x:Space remaining on the current line.\n» «k:mutable» pp_space_left : «t:int»;\n «m:/// »«x:Current value of indentation.\n» «k:mutable» pp_current_indent : «t:int»;\n «m:/// »«x:True when the line has been broken by the pretty-printer.\n» «k:mutable» pp_is_new_line : «t:bool»;\n «m:/// »«x:Total width of tokens already printed.\n» «k:mutable» pp_left_total : «t:int»;\n «m:/// »«x:Total width of tokens ever put in queue.\n» «k:mutable» pp_right_total : «t:int»;\n «m:/// »«x:Current number of opened blocks.\n» «k:mutable» pp_curr_depth : «t:int»;\n «m:/// »«x:Maximum number of blocks which can be simultaneously opened.\n» «k:mutable» pp_max_boxes : «t:int»;\n «m:/// »«x:Ellipsis string.\n» «k:mutable» pp_ellipsis : «t:string»;\n «m:/// »«x:Output function.\n» «k:mutable» pp_out_string : «t:string» -> int -> int -> unit;\n «m:/// »«x:Flushing function.\n» «k:mutable» pp_out_flush : «t:unit» -> unit;\n «m:/// »«x:Output of new lines.\n» «k:mutable» pp_out_newline : «t:unit» -> unit;\n «m:/// »«x:Output of indentation spaces.\n» «k:mutable» pp_out_spaces : «t:int» -> unit;\n «m:/// »«x:Are tags printed?\n» «k:mutable» pp_print_tags : «t:bool»;\n «m:/// »«x:Are tags marked?\n» «k:mutable» pp_mark_tags : «t:bool»;\n «m:/// »«x:Find opening and closing markers of tags.\n» «k:mutable» pp_mark_open_tag : «t:tag» -> string;\n «k:mutable» pp_mark_close_tag : «t:tag» -> string;\n «k:mutable» pp_print_open_tag : «t:tag» -> unit;\n «k:mutable» pp_print_close_tag : «t:tag» -> unit;\n «m:/// »«x:The pretty-printer queue.\n» «k:mutable» pp_queue : «t:pp_queue_elem queue»\n }\n\n«x:(**************************************************************\n\n Auxilliaries and basic functions.\n\n **************************************************************)»\n«m:/// »«x:Queues auxilliaries.\n»«k:let» «f:make_queue» () = { insert = Nil; body = Nil; }\n \n«k:let» «f:clear_queue» «v:q» =\n q.insert <- Nil\n q.body <- Nil\n \n«k:let» «f:add_queue» «v:x» «v:q» =\n «k:let» «v:c» = Cons { head = x; tail = Nil; }\n «k:match» q «k:with»\n «:fsharp-ui-operator-face:|» { insert = Cons cell; body = _ } ->\n (q.insert <- c; cell.tail <- c)\n «:fsharp-ui-operator-face:|» «x:(* Invariant: when insert is Nil body should be Nil. *)»\n { insert = Nil; body = _ } -> (q.insert <- c; q.body <- c)\n \n«k:exception» Empty_queue\n \n«k:let» «v:peek_queue» =\n «k:function»\n «:fsharp-ui-operator-face:|» { body = Cons { head = x; tail = _ }; insert = _ } -> x\n «:fsharp-ui-operator-face:|» { body = Nil; insert = _ } -> raise Empty_queue\n \n«k:let» «v:take_queue» =\n «k:function»\n «:fsharp-ui-operator-face:|» ({ body = Cons { head = x; tail = tl }; insert = _ } «k:as» q) ->\n (q.body <- tl;\n «k:if» tl = Nil «k:then» q.insert <- Nil «k:else» ();\n «x:(* Maintain the invariant. *)»\n x)\n «:fsharp-ui-operator-face:|» { body = Nil; insert = _ } -> raise Empty_queue\n \n«x:(* Enter a token in the pretty-printer queue. *)»\n«k:let» «f:pp_enqueue» «v:state» (({ «v:length» = len; elem_size = _; token = _ } «k:as» token)) =\n state.pp_right_total <- state.pp_right_total + len\n add_queue token state.pp_queue\n \n«k:let» «f:pp_clear_queue» «v:state» =\n state.pp_left_total <- 1\n state.pp_right_total <- 1\n clear_queue state.pp_queue\n \n«x:(* Pp_infinity: large value for default tokens size.\n\n Pp_infinity is documented as being greater than 1e10; to avoid\n confusion about the word ``greater'', we choose pp_infinity greater\n than 1e10 + 1; for correct handling of tests in the algorithm,\n pp_infinity must be even one more than 1e10 + 1; let's stand on the\n safe side by choosing 1.e10+10.\n\n Pp_infinity could probably be 1073741823 that is 2^30 - 1, that is\n the minimal upper bound for integers; now that max_int is defined,\n this limit could also be defined as max_int - 1.\n\n However, before setting pp_infinity to something around max_int, we\n must carefully double-check all the integer arithmetic operations\n that involve pp_infinity, since any overflow would wreck havoc the\n pretty-printing algorithm's invariants. Given that this arithmetic\n correctness check is difficult and error prone and given that 1e10\n + 1 is in practice large enough, there is no need to attempt to set\n pp_infinity to the theoretically maximum limit. It is not worth the\n burden ! *)»\n«k:let» «v:pp_infinity» = 1000000010\n \n«x:(* Output functions for the formatter. *)»\n«k:let» «k:rec» «f:pp_output_string» «v:state» «v:s» = state.pp_out_string s 0 (String.length s)\n«k:and» «f:pp_output_newline» «v:state» = state.pp_out_newline ()\n«k:and» «f:pp_output_spaces» «v:state» «v:n» = state.pp_out_spaces n\n \n«x:(* To format a break, indenting a new line. *)»\n«k:let» «f:break_new_line» «v:state» «v:offset» «v:width» =\n (pp_output_newline state;\n state.pp_is_new_line <- «k:true»;\n «k:let» «v:indent» = (state.pp_margin - width) + offset «k:in»\n «x:(* Don't indent more than pp_max_indent. *)»\n «k:let» «v:real_indent» = min state.pp_max_indent indent\n «k:in»\n (state.pp_current_indent <- real_indent;\n state.pp_space_left <- state.pp_margin - state.pp_current_indent;\n pp_output_spaces state state.pp_current_indent))\n \n«x:(* To force a line break inside a block: no offset is added. *)»\n«k:let» «f:break_line» «v:state» «v:width» = break_new_line state 0 width\n \n«x:(* To format a break that fits on the current line. *)»\n«k:let» «f:break_same_line» «v:state» «v:width» =\n (state.pp_space_left <- state.pp_space_left - width;\n pp_output_spaces state width)\n \n«x:(* To indent no more than pp_max_indent, if one tries to open a block\n beyond pp_max_indent, then the block is rejected on the left\n by simulating a break. *)»\n«k:let» «f:pp_force_break_line» «v:state» =\n «k:match» state.pp_format_stack «k:with»\n «:fsharp-ui-operator-face:|» Format_elem (bl_ty, width) :: _ ->\n «k:if» width > state.pp_space_left\n «k:then»\n («k:match» bl_ty «k:with»\n «:fsharp-ui-operator-face:|» Pp_fits -> ()\n «:fsharp-ui-operator-face:|» Pp_hbox -> ()\n «: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)\n «k:else» ()\n «:fsharp-ui-operator-face:|» [] -> pp_output_newline state\n \n«x:(* To skip a token, if the previous line has been broken. *)»\n«k:let» «f:pp_skip_token» «v:state» =\n «x:(* When calling pp_skip_token the queue cannot be empty. *)»\n «k:match» take_queue state.pp_queue «k:with»\n «:fsharp-ui-operator-face:|» { elem_size = size; length = len; token = _ } ->\n (state.pp_left_total <- state.pp_left_total - len;\n state.pp_space_left <- state.pp_space_left + (int_of_size size))\n \n«x:(**************************************************************\n\n The main pretty printing functions.\n\n **************************************************************)»\n«x:(* To format a token. *)»\n«k:let» «f:format_pp_token» «v:state» «v:size» =\n «k:function»\n «:fsharp-ui-operator-face:|» Pp_text s ->\n (state.pp_space_left <- state.pp_space_left - size;\n pp_output_string state s;\n state.pp_is_new_line <- «k:false»)\n «:fsharp-ui-operator-face:|» Pp_begin (off, ty) ->\n «k:let» «v:insertion_point» = state.pp_margin - state.pp_space_left\n «k:in»\n («k:if» insertion_point > state.pp_max_indent\n «k:then» «x:(* can't open a block right there. *)» pp_force_break_line state\n «k:else» ();\n «k:let» «v:offset» = state.pp_space_left - off «k:in»\n «k:let» «v:bl_type» =\n («k:match» ty «k:with»\n «:fsharp-ui-operator-face:|» Pp_vbox -> Pp_vbox\n «: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 ->\n «k:if» size > state.pp_space_left «k:then» ty «k:else» Pp_fits)\n «k:in»\n state.pp_format_stack <-\n (Format_elem (bl_type, offset)) :: state.pp_format_stack)\n «:fsharp-ui-operator-face:|» Pp_end ->\n («k:match» state.pp_format_stack «k:with»\n «:fsharp-ui-operator-face:|» _ :: ls -> state.pp_format_stack <- ls\n «:fsharp-ui-operator-face:|» [] -> ())\n «:fsharp-ui-operator-face:|» «x:(* No more block to close. *)» Pp_tbegin ((Pp_tbox _ «k:as» tbox)) ->\n state.pp_tbox_stack <- tbox :: state.pp_tbox_stack\n «:fsharp-ui-operator-face:|» Pp_tend ->\n («k:match» state.pp_tbox_stack «k:with»\n «:fsharp-ui-operator-face:|» _ :: ls -> state.pp_tbox_stack <- ls\n «:fsharp-ui-operator-face:|» [] -> ())\n «:fsharp-ui-operator-face:|» «x:(* No more tabulation block to close. *)» Pp_stab ->\n («k:match» state.pp_tbox_stack «k:with»\n «:fsharp-ui-operator-face:|» Pp_tbox tabs :: _ ->\n «k:let» «k:rec» «f:add_tab» «v:n» =\n («k:function»\n «:fsharp-ui-operator-face:|» [] -> [ n ]\n «:fsharp-ui-operator-face:|» (x :: l «k:as» ls) ->\n «k:if» n < x «k:then» n :: ls «k:else» x :: (add_tab n l))\n «k:in» tabs := add_tab (state.pp_margin - state.pp_space_left) !tabs\n «:fsharp-ui-operator-face:|» [] -> ())\n «:fsharp-ui-operator-face:|» «x:(* No opened tabulation block. *)» Pp_tbreak (n, off) ->\n «k:let» «v:insertion_point» = state.pp_margin - state.pp_space_left\n «k:in»\n («k:match» state.pp_tbox_stack «k:with»\n «:fsharp-ui-operator-face:|» Pp_tbox tabs :: _ ->\n «k:let» «k:rec» «f:find» «v:n» =\n («k:function»\n «:fsharp-ui-operator-face:|» x :: l -> «k:if» x >= n «k:then» x «k:else» find n l\n «:fsharp-ui-operator-face:|» [] -> raise Not_found) «k:in»\n «k:let» «v:tab» =\n («k:match» !tabs «k:with»\n «:fsharp-ui-operator-face:|» x :: _ ->\n («k:try» find insertion_point !tabs «k:with» «:fsharp-ui-operator-face:|» Not_found -> x)\n «:fsharp-ui-operator-face:|» _ -> insertion_point) «k:in»\n «k:let» «v:offset» = tab - insertion_point\n «k:in»\n «k:if» offset >= 0\n «k:then» break_same_line state (offset + n)\n «k:else» break_new_line state (tab + off) state.pp_margin\n «:fsharp-ui-operator-face:|» [] -> ())\n «:fsharp-ui-operator-face:|» «x:(* No opened tabulation block. *)» Pp_newline ->\n («k:match» state.pp_format_stack «k:with»\n «:fsharp-ui-operator-face:|» Format_elem (_, width) :: _ -> break_line state width\n «:fsharp-ui-operator-face:|» [] -> pp_output_newline state)\n «:fsharp-ui-operator-face:|» «x:(* No opened block. *)» Pp_if_newline ->\n «k:if» state.pp_current_indent <> (state.pp_margin - state.pp_space_left)\n «k:then» pp_skip_token state\n «:fsharp-ui-operator-face:|» Pp_break (n, off) ->\n («k:match» state.pp_format_stack «k:with»\n «:fsharp-ui-operator-face:|» Format_elem (ty, width) :: _ ->\n («k:match» ty «k:with»\n «:fsharp-ui-operator-face:|» Pp_hovbox ->\n «k:if» size > state.pp_space_left\n «k:then» break_new_line state off width\n «k:else» break_same_line state n\n «:fsharp-ui-operator-face:|» Pp_box -> «x:(* Have the line just been broken here ? *)»\n «k:if» state.pp_is_new_line\n «k:then» break_same_line state n\n «k:else»\n «k:if» size > state.pp_space_left\n «k:then» break_new_line state off width\n «k:else» «x:(* break the line here leads to new indentation ? *)»\n «k:if»\n state.pp_current_indent >\n ((state.pp_margin - width) + off)\n «k:then» break_new_line state off width\n «k:else» break_same_line state n\n «:fsharp-ui-operator-face:|» Pp_hvbox -> break_new_line state off width\n «:fsharp-ui-operator-face:|» Pp_fits -> break_same_line state n\n «:fsharp-ui-operator-face:|» Pp_vbox -> break_new_line state off width\n «:fsharp-ui-operator-face:|» Pp_hbox -> break_same_line state n)\n «:fsharp-ui-operator-face:|» [] -> ())\n «:fsharp-ui-operator-face:|» «x:(* No opened block. *)» Pp_open_tag tag_name ->\n «k:let» «v:marker» = state.pp_mark_open_tag tag_name\n «k:in»\n (pp_output_string state marker;\n state.pp_mark_stack <- tag_name :: state.pp_mark_stack)\n «:fsharp-ui-operator-face:|» Pp_close_tag ->\n («k:match» state.pp_mark_stack «k:with»\n «:fsharp-ui-operator-face:|» tag_name :: tags ->\n «k:let» «v:marker» = state.pp_mark_close_tag tag_name\n «k:in» (pp_output_string state marker; state.pp_mark_stack <- tags)\n «:fsharp-ui-operator-face:|» [] -> ())\n \n«x:(* No more tag to close. *)»\n«x:(* Print if token size is known or printing is delayed.\n Size is known when not negative.\n Printing is delayed when the text waiting in the queue requires\n more room to format than exists on the current line.\n\n Note: [advance_loop] must be tail recursive to prevent stack overflows. *)»\n«k:let» «k:rec» «f:advance_loop» «v:state» =\n «k:match» peek_queue state.pp_queue «k:with»\n «:fsharp-ui-operator-face:|» { elem_size = size; token = tok; length = len } ->\n «k:let» «v:size» = int_of_size size\n «k:in»\n «k:if»\n «k:not»\n ((size < 0) &&\n ((state.pp_right_total - state.pp_left_total) <\n state.pp_space_left))\n «k:then»\n (ignore (take_queue state.pp_queue);\n format_pp_token state («k:if» size < 0 «k:then» pp_infinity «k:else» size) tok;\n state.pp_left_total <- len + state.pp_left_total;\n advance_loop state)\n «k:else» ()\n \n«k:let» «f:advance_left» «v:state» = «k:try» advance_loop state «k:with» «:fsharp-ui-operator-face:|» Empty_queue -> ()\n \n«k:let» «f:enqueue_advance» «v:state» «v:tok» = (pp_enqueue state tok; advance_left state)\n \n«x:(* To enqueue a string : try to advance. *)»\n«k:let» «f:make_queue_elem» «v:size» «v:tok» «v:len» =\n { elem_size = size; token = tok; length = len; }\n \n«k:let» «f:enqueue_string_as» «v:state» «v:size» «v:s» =\n «k:let» «v:len» = int_of_size size\n «k:in» enqueue_advance state (make_queue_elem size (Pp_text s) len)\n \n«k:let» «f:enqueue_string» «v:state» «v:s» =\n «k:let» «v:len» = String.length s «k:in» enqueue_string_as state (size_of_int len) s\n \n«x:(* Routines for scan stack\n determine sizes of blocks. *)»\n«x:(* The scan_stack is never empty. *)»\n«k:let» «v:scan_stack_bottom» =\n «k:let» «v:q_elem» = make_queue_elem (size_of_int (-1)) (Pp_text «s:\"\"») 0\n «k:in» [ Scan_elem ((-1), q_elem) ]\n \n«x:(* Set size of blocks on scan stack:\n if ty = true then size of break is set else size of block is set;\n in each case pp_scan_stack is popped. *)»\n«k:let» «f:clear_scan_stack» «v:state» = state.pp_scan_stack <- scan_stack_bottom\n \n«x:(* Pattern matching on scan stack is exhaustive,\n since scan_stack is never empty.\n Pattern matching on token in scan stack is also exhaustive,\n since scan_push is used on breaks and opening of boxes. *)»\n«k:let» «f:set_size» «v:state» «v:ty» =\n «k:match» state.pp_scan_stack «k:with»\n «:fsharp-ui-operator-face:|» Scan_elem (left_tot,\n (({ elem_size = size; token = tok; length = _ } «k:as» queue_elem))) :: t\n ->\n «k:let» «v:size» = int_of_size size\n «k:in»\n «x:(* test if scan stack contains any data that is not obsolete. *)»\n «k:if» left_tot < state.pp_left_total\n «k:then» clear_scan_stack state\n «k:else»\n («k:match» tok «k:with»\n «:fsharp-ui-operator-face:|» Pp_break (_, _) «:fsharp-ui-operator-face:|» Pp_tbreak (_, _) ->\n «k:if» ty\n «k:then»\n (queue_elem.elem_size <-\n size_of_int (state.pp_right_total + size);\n state.pp_scan_stack <- t)\n «k:else» ()\n «:fsharp-ui-operator-face:|» Pp_begin (_, _) ->\n «k:if» «k:not» ty\n «k:then»\n (queue_elem.elem_size <-\n size_of_int (state.pp_right_total + size);\n state.pp_scan_stack <- t)\n «k:else» ()\n «: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 |\n Pp_newline «:fsharp-ui-operator-face:|» Pp_if_newline «:fsharp-ui-operator-face:|» Pp_open_tag _ «:fsharp-ui-operator-face:|» Pp_close_tag ->\n ())\n «:fsharp-ui-operator-face:|» «x:(* scan_push is only used for breaks and boxes. *)» [] -> ()\n \n«x:(* scan_stack is never empty. *)»\n«x:(* Push a token on scan stack. If b is true set_size is called. *)»\n«k:let» «f:scan_push» «v:state» «v:b» «v:tok» =\n (pp_enqueue state tok;\n «k:if» b «k:then» set_size state «k:true» «k:else» ();\n state.pp_scan_stack <-\n (Scan_elem (state.pp_right_total, tok)) :: state.pp_scan_stack)\n \n«x:(* To open a new block :\n the user may set the depth bound pp_max_boxes\n any text nested deeper is printed as the ellipsis string. *)»\n«k:let» «f:pp_open_box_gen» «v:state» «v:indent» «v:br_ty» =\n (state.pp_curr_depth <- state.pp_curr_depth + 1;\n «k:if» state.pp_curr_depth < state.pp_max_boxes\n «k:then»\n («k:let» elem =\n make_queue_elem (size_of_int (- state.pp_right_total))\n (Pp_begin (indent, br_ty)) 0\n «k:in» scan_push state «k:false» elem)\n «k:else»\n «k:if» state.pp_curr_depth = state.pp_max_boxes\n «k:then» enqueue_string state state.pp_ellipsis\n «k:else» ())\n \n«x:(* The box which is always opened. *)»\n«k:let» «f:pp_open_sys_box» «v:state» = pp_open_box_gen state 0 Pp_hovbox\n \n«x:(* Close a block, setting sizes of its sub blocks. *)»\n«k:let» «f:pp_close_box» «v:state» () =\n «k:if» state.pp_curr_depth > 1\n «k:then»\n («k:if» state.pp_curr_depth < state.pp_max_boxes\n «k:then»\n (pp_enqueue state\n { elem_size = size_of_int 0; token = Pp_end; length = 0; };\n set_size state «k:true»;\n set_size state «k:false»)\n «k:else» ();\n state.pp_curr_depth <- state.pp_curr_depth - 1)\n «k:else» ()\n \n«x:(* Open a tag, pushing it on the tag stack. *)»\n«k:let» «f:pp_open_tag» «v:state» «v:tag_name» =\n («k:if» state.pp_print_tags\n «k:then»\n (state.pp_tag_stack <- tag_name :: state.pp_tag_stack;\n state.pp_print_open_tag tag_name)\n «k:else» ();\n «k:if» state.pp_mark_tags\n «k:then»\n pp_enqueue state\n { elem_size = size_of_int 0; token = Pp_open_tag tag_name; length = 0;\n }\n «k:else» ())\n \n«x:(* Close a tag, popping it from the tag stack. *)»\n«k:let» «f:pp_close_tag» «v:state» () =\n («k:if» state.pp_mark_tags\n «k:then»\n pp_enqueue state\n { elem_size = size_of_int 0; token = Pp_close_tag; length = 0; }\n «k:else» ();\n «k:if» state.pp_print_tags\n «k:then»\n («k:match» state.pp_tag_stack «k:with»\n «:fsharp-ui-operator-face:|» tag_name :: tags ->\n (state.pp_print_close_tag tag_name; state.pp_tag_stack <- tags)\n «:fsharp-ui-operator-face:|» _ -> ())\n «k:else» ())\n \n«x:(* No more tag to close. *)»\n«k:let» «f:pp_set_print_tags» «v:state» «v:b» = state.pp_print_tags <- b\n \n«k:let» «f:pp_set_mark_tags» «v:state» «v:b» = state.pp_mark_tags <- b\n \n«k:let» «f:pp_get_print_tags» «v:state» () = state.pp_print_tags\n \n«k:let» «f:pp_get_mark_tags» «v:state» () = state.pp_mark_tags\n \n«k:let» «f:pp_set_tags» «v:state» «v:b» =\n (pp_set_print_tags state b; pp_set_mark_tags state b)\n \n«k:let» «f:pp_get_formatter_tag_functions» «v:state» () =\n {\n mark_open_tag = state.pp_mark_open_tag;\n mark_close_tag = state.pp_mark_close_tag;\n print_open_tag = state.pp_print_open_tag;\n print_close_tag = state.pp_print_close_tag;\n }\n \n«k:let» «f:pp_set_formatter_tag_functions» «v:state»\n {\n «v:mark_open_tag» = mot;\n mark_close_tag = mct;\n print_open_tag = pot;\n print_close_tag = pct\n } =\n (state.pp_mark_open_tag <- mot;\n state.pp_mark_close_tag <- mct;\n state.pp_print_open_tag <- pot;\n state.pp_print_close_tag <- pct)\n \n«x:(* Initialize pretty-printer. *)»\n«k:let» «f:pp_rinit» «v:state» =\n (pp_clear_queue state;\n clear_scan_stack state;\n state.pp_format_stack <- [];\n state.pp_tbox_stack <- [];\n state.pp_tag_stack <- [];\n state.pp_mark_stack <- [];\n state.pp_current_indent <- 0;\n state.pp_curr_depth <- 0;\n state.pp_space_left <- state.pp_margin;\n pp_open_sys_box state)\n \n«x:(* Flushing pretty-printer queue. *)»\n«k:let» «f:pp_flush_queue» «v:state» «v:b» =\n («k:while» state.pp_curr_depth > 1 «k:do» pp_close_box state () «k:done»;\n state.pp_right_total <- pp_infinity;\n advance_left state;\n «k:if» b «k:then» pp_output_newline state «k:else» ();\n pp_rinit state)\n \n«x:(**************************************************************\n\n Procedures to format objects, and use boxes\n\n **************************************************************)»\n«x:(* To format a string. *)»\n«k:let» «f:pp_print_as_size» «v:state» «v:size» «v:s» =\n «k:if» state.pp_curr_depth < state.pp_max_boxes\n «k:then» enqueue_string_as state size s\n «k:else» ()\n \n«k:let» «f:pp_print_as» «v:state» «v:isize» «v:s» = pp_print_as_size state (size_of_int isize) s\n \n«k:let» «f:pp_print_string» «v:state» «v:s» = pp_print_as state (String.length s) s\n \n«x:(* To format an integer. *)»\n«k:let» «f:pp_print_int» «v:state» «v:i» = pp_print_string state (string_of_int i)\n \n«x:(* To format a float. *)»\n«k:let» «f:pp_print_float» «v:state» «v:f» = pp_print_string state (string_of_float f)\n \n«x:(* To format a boolean. *)»\n«k:let» «f:pp_print_bool» «v:state» «v:b» = pp_print_string state (string_of_bool b)\n \n«x:(* To format a char. *)»\n«k:let» «f:pp_print_char» «v:state» («v:c» : «t:char») =\n pp_print_as state 1 (string c)\n \n«x:(* Opening boxes. *)»\n«k:let» «k:rec» «f:pp_open_hbox» «v:state» () = pp_open_box_gen state 0 Pp_hbox\n«k:and» «f:pp_open_vbox» «v:state» «v:indent» = pp_open_box_gen state indent Pp_vbox\n«k:and» «f:pp_open_hvbox» «v:state» «v:indent» = pp_open_box_gen state indent Pp_hvbox\n«k:and» «f:pp_open_hovbox» «v:state» «v:indent» = pp_open_box_gen state indent Pp_hovbox\n«k:and» «f:pp_open_box» «v:state» «v:indent» = pp_open_box_gen state indent Pp_box\n \n«x:(* Print a new line after printing all queued text\n (same for print_flush but without a newline). *)»\n«k:let» «k:rec» «f:pp_print_newline» «v:state» () =\n pp_flush_queue state «k:true»\n state.pp_out_flush ()\n«k:and» «f:pp_print_flush» «v:state» () =\n pp_flush_queue state «k:false»\n state.pp_out_flush ()\n \n«x:(* To get a newline when one does not want to close the current block. *)»\n«k:let» «f:pp_force_newline» «v:state» () =\n «k:if» state.pp_curr_depth < state.pp_max_boxes\n «k:then» enqueue_advance state (make_queue_elem (size_of_int 0) Pp_newline 0)\n «k:else» ()\n \n«x:(* To format something if the line has just been broken. *)»\n«k:let» «f:pp_print_if_newline» «v:state» () =\n «k:if» state.pp_curr_depth < state.pp_max_boxes\n «k:then»\n enqueue_advance state (make_queue_elem (size_of_int 0) Pp_if_newline 0)\n «k:else» ()\n \n«x:(* Breaks: indicate where a block may be broken.\n If line is broken then offset is added to the indentation of the current\n block else (the value of) width blanks are printed.\n To do (?) : add a maximum width and offset value. *)»\n«k:let» «f:pp_print_break» «v:state» «v:width» «v:offset» =\n «k:if» state.pp_curr_depth < state.pp_max_boxes\n «k:then»\n («k:let» elem =\n make_queue_elem (size_of_int (- state.pp_right_total))\n (Pp_break (width, offset)) width\n «k:in» scan_push state «k:true» elem)\n «k:else» ()\n \n«k:let» «k:rec» «f:pp_print_space» «v:state» () = pp_print_break state 1 0\n«k:and» «f:pp_print_cut» «v:state» () = pp_print_break state 0 0\n \n«x:(* Tabulation boxes. *)»\n«k:let» «f:pp_open_tbox» «v:state» () =\n (state.pp_curr_depth <- state.pp_curr_depth + 1;\n «k:if» state.pp_curr_depth < state.pp_max_boxes\n «k:then»\n («k:let» elem =\n make_queue_elem (size_of_int 0) (Pp_tbegin (Pp_tbox (ref []))) 0\n «k:in» enqueue_advance state elem)\n «k:else» ())\n \n«x:(* Close a tabulation block. *)»\n«k:let» «f:pp_close_tbox» «v:state» () =\n «k:if» state.pp_curr_depth > 1\n «k:then»\n «k:if» state.pp_curr_depth < state.pp_max_boxes\n «k:then»\n («k:let» elem = make_queue_elem (size_of_int 0) Pp_tend 0\n «k:in»\n (enqueue_advance state elem;\n state.pp_curr_depth <- state.pp_curr_depth - 1))\n «k:else» ()\n «k:else» ()\n \n«x:(* Print a tabulation break. *)»\n«k:let» «f:pp_print_tbreak» «v:state» «v:width» «v:offset» =\n «k:if» state.pp_curr_depth < state.pp_max_boxes\n «k:then»\n («k:let» elem =\n make_queue_elem (size_of_int (- state.pp_right_total))\n (Pp_tbreak (width, offset)) width\n «k:in» scan_push state «k:true» elem)\n «k:else» ()\n \n«k:let» «f:pp_print_tab» «v:state» () = pp_print_tbreak state 0 0\n \n«k:let» «f:pp_set_tab» «v:state» () =\n «k:if» state.pp_curr_depth < state.pp_max_boxes\n «k:then»\n («k:let» elem = make_queue_elem (size_of_int 0) Pp_stab 0\n «k:in» enqueue_advance state elem)\n «k:else» ()\n \n«x:(**************************************************************\n\n Procedures to control the pretty-printers\n\n **************************************************************)»\n«x:(* Fit max_boxes. *)»\n«k:let» «f:pp_set_max_boxes» «v:state» «v:n» = «k:if» n > 1 «k:then» state.pp_max_boxes <- n «k:else» ()\n \n«x:(* To know the current maximum number of boxes allowed. *)»\n«k:let» «f:pp_get_max_boxes» «v:state» () = state.pp_max_boxes\n \n«k:let» «f:pp_over_max_boxes» «v:state» () = state.pp_curr_depth = state.pp_max_boxes\n \n«x:(* Ellipsis. *)»\n«k:let» «k:rec» «f:pp_set_ellipsis_text» «v:state» «v:s» = state.pp_ellipsis <- s\n«k:and» «f:pp_get_ellipsis_text» «v:state» () = state.pp_ellipsis\n \n«x:(* To set the margin of pretty-printer. *)»\n«k:let» «f:pp_limit» «v:n» = «k:if» n < pp_infinity «k:then» n «k:else» pred pp_infinity\n \n«k:let» «f:pp_set_min_space_left» «v:state» «v:n» =\n «k:if» n >= 1\n «k:then»\n («k:let» n = pp_limit n\n «k:in»\n (state.pp_min_space_left <- n;\n state.pp_max_indent <- state.pp_margin - state.pp_min_space_left;\n pp_rinit state))\n «k:else» ()\n \n«x:(* Initially, we have :\n pp_max_indent = pp_margin - pp_min_space_left, and\n pp_space_left = pp_margin. *)»\n«k:let» «f:pp_set_max_indent» «v:state» «v:n» =\n pp_set_min_space_left state (state.pp_margin - n)\n \n«k:let» «f:pp_get_max_indent» «v:state» () = state.pp_max_indent\n \n«k:let» «f:pp_set_margin» «v:state» «v:n» =\n «k:if» n >= 1\n «k:then»\n («k:let» n = pp_limit n\n «k:in»\n (state.pp_margin <- n;\n «k:let» «v:new_max_indent» =\n «x:(* Try to maintain max_indent to its actual value. *)»\n «k:if» state.pp_max_indent <= state.pp_margin\n «k:then» state.pp_max_indent\n «k:else»\n «x:(* If possible maintain pp_min_space_left to its actual value,\n if this leads to a too small max_indent, take half of the\n new margin, if it is greater than 1. *)»\n max\n (max (state.pp_margin - state.pp_min_space_left)\n (state.pp_margin / 2))\n 1\n «k:in» «x:(* Rebuild invariants. *)» pp_set_max_indent state new_max_indent))\n «k:else» ()\n \n«k:let» «f:pp_get_margin» «v:state» () = state.pp_margin\n \n«k:type» «t:formatter_out_functions» = {\n out_string : «t:string» -> int -> int -> unit;\n out_flush : «t:unit» -> unit;\n out_newline : «t:unit» -> unit;\n out_spaces : «t:int» -> unit\n }\n\n«k:let» «f:pp_set_formatter_out_functions» «v:state»\n {\n «v:out_string» = f;\n out_flush = g;\n out_newline = h;\n out_spaces = i\n } =\n state.pp_out_string <- f\n state.pp_out_flush <- g\n state.pp_out_newline <- h\n state.pp_out_spaces <- i\n \n«k:let» «f:pp_get_formatter_out_functions» «v:state» () =\n {\n out_string = state.pp_out_string;\n out_flush = state.pp_out_flush;\n out_newline = state.pp_out_newline;\n out_spaces = state.pp_out_spaces;\n }\n \n«k:let» «f:pp_set_formatter_output_functions» «v:state» «v:f» «v:g» =\n (state.pp_out_string <- f; state.pp_out_flush <- g)\n \n«k:let» «f:pp_get_formatter_output_functions» «v:state» () =\n state.pp_out_string, state.pp_out_flush\n \n«m://»«x:let pp_set_all_formatter_output_functions state ~out:f ~flush:g ~newline:h ~spaces:i =\n»«k:let» «f:pp_set_all_formatter_output_functions» «v:state» «v:f» «v:g» «v:h» «v:i» =\n pp_set_formatter_output_functions state f g\n state.pp_out_newline <- h\n state.pp_out_spaces <- i\n \n«k:let» «f:pp_get_all_formatter_output_functions» «v:state» () =\n state.pp_out_string,\n state.pp_out_flush,\n state.pp_out_newline,\n state.pp_out_spaces\n \n«x:(* Default function to output new lines. *)»\n«k:let» «f:display_newline» «v:state» () = state.pp_out_string «s:\"\\n\"» 0 1\n \n«x:(* Default function to output spaces. *)»\n«k:let» «v:blank_line» = String.make 80 «s:' '»\n \n«k:let» «k:rec» «f:display_blanks» «v:state» «v:n» =\n «k:if» n > 0 «k:then»\n «k:if» n <= 80\n «k:then» state.pp_out_string blank_line 0 n\n «k:else» (state.pp_out_string blank_line 0 80; display_blanks state (n - 80))\n \n«m:/// »«x:Re-implementation of OCaml's Pervasives.output, since the one in the\n»«m:/// »«x:F# compatibility library doesn't have the right type signature.\n»«k:let» «k:private» «f:output» «v:oc» («v:buf» : «t:string») («v:pos» : «t:int») («v:len» : «t:int») =\n output_string oc (buf.Substring (pos, len))\n\n«k:let» «f:pp_set_formatter_out_channel» «v:state» «v:os» =\n state.pp_out_string <- output os\n state.pp_out_flush <- («k:fun» () -> flush os)\n state.pp_out_newline <- display_newline state\n state.pp_out_spaces <- display_blanks state\n \n«x:(**************************************************************\n\n Creation of specific formatters\n\n **************************************************************)»\n«k:let» «f:default_pp_mark_open_tag» «v:s» = «s:\"<\"» ^ (s ^ «s:\">\"»)\n \n«k:let» «f:default_pp_mark_close_tag» «v:s» = «s:\"\"»)\n \n«k:let» «v:default_pp_print_open_tag» = ignore\n \n«k:let» «v:default_pp_print_close_tag» = ignore\n \n«k:let» «f:pp_make_formatter» «v:f» «v:g» «v:h» «v:i» =\n «x:(* The initial state of the formatter contains a dummy box. *)»\n «k:let» «v:pp_q» = make_queue () «k:in»\n «k:let» «v:sys_tok» =\n make_queue_elem (size_of_int (-1)) (Pp_begin (0, Pp_hovbox)) 0\n «k:in»\n (add_queue sys_tok pp_q;\n «k:let» «v:sys_scan_stack» = (Scan_elem (1, sys_tok)) :: scan_stack_bottom\n «k:in»\n {\n pp_scan_stack = sys_scan_stack;\n pp_format_stack = [];\n pp_tbox_stack = [];\n pp_tag_stack = [];\n pp_mark_stack = [];\n pp_margin = 78;\n pp_min_space_left = 10;\n pp_max_indent = 78 - 10;\n pp_space_left = 78;\n pp_current_indent = 0;\n pp_is_new_line = «k:true»;\n pp_left_total = 1;\n pp_right_total = 1;\n pp_curr_depth = 1;\n pp_max_boxes = max_int;\n pp_ellipsis = «s:\".\"»;\n pp_out_string = f;\n pp_out_flush = g;\n pp_out_newline = h;\n pp_out_spaces = i;\n pp_print_tags = «k:false»;\n pp_mark_tags = «k:false»;\n pp_mark_open_tag = default_pp_mark_open_tag;\n pp_mark_close_tag = default_pp_mark_close_tag;\n pp_print_open_tag = default_pp_print_open_tag;\n pp_print_close_tag = default_pp_print_close_tag;\n pp_queue = pp_q;\n })\n \n«x:(* Make a formatter with default functions to output spaces and new lines. *)»\n«k:let» «f:make_formatter» «v:output» «v:flush» =\n «k:let» «v:ppf» = pp_make_formatter output flush ignore ignore\n «k:in»\n (ppf.pp_out_newline <- display_newline ppf;\n ppf.pp_out_spaces <- display_blanks ppf;\n ppf)\n \n«k:let» «f:formatter_of_out_channel» «v:oc» =\n make_formatter (output oc) («k:fun» () -> flush oc)\n \n«k:let» «f:formatter_of_buffer» «v:b» = make_formatter (Buffer.add_substring b) ignore\n \n«k:let» «v:stdbuf» = Buffer.create 512\n \n«x:(* Predefined formatters. *)»\n«k:let» «k:rec» «v:std_formatter» = formatter_of_out_channel Pervasives.stdout\n«k:and» «v:err_formatter» = formatter_of_out_channel Pervasives.stderr\n«k:and» «v:str_formatter» = formatter_of_buffer stdbuf\n \n«k:let» «f:flush_str_formatter» () =\n (pp_flush_queue str_formatter «k:false»;\n «k:let» «v:s» = Buffer.contents stdbuf «k:in» (Buffer.reset stdbuf; s))\n \n«x:(**************************************************************\n\n Basic functions on the standard formatter\n\n **************************************************************)»\n«k:let» «k:rec» «v:open_hbox» = pp_open_hbox std_formatter\n«k:and» «v:open_vbox» = pp_open_vbox std_formatter\n«k:and» «v:open_hvbox» = pp_open_hvbox std_formatter\n«k:and» «v:open_hovbox» = pp_open_hovbox std_formatter\n«k:and» «v:open_box» = pp_open_box std_formatter\n«k:and» «v:close_box» = pp_close_box std_formatter\n«k:and» «v:open_tag» = pp_open_tag std_formatter\n«k:and» «v:close_tag» = pp_close_tag std_formatter\n«k:and» «v:print_as» = pp_print_as std_formatter\n«k:and» «v:print_string» = pp_print_string std_formatter\n«k:and» «v:print_int» = pp_print_int std_formatter\n«k:and» «v:print_float» = pp_print_float std_formatter\n«k:and» «v:print_char» = pp_print_char std_formatter\n«k:and» «v:print_bool» = pp_print_bool std_formatter\n«k:and» «v:print_break» = pp_print_break std_formatter\n«k:and» «v:print_cut» = pp_print_cut std_formatter\n«k:and» «v:print_space» = pp_print_space std_formatter\n«k:and» «v:force_newline» = pp_force_newline std_formatter\n«k:and» «v:print_flush» = pp_print_flush std_formatter\n«k:and» «v:print_newline» = pp_print_newline std_formatter\n«k:and» «v:print_if_newline» = pp_print_if_newline std_formatter\n«k:and» «v:open_tbox» = pp_open_tbox std_formatter\n«k:and» «v:close_tbox» = pp_close_tbox std_formatter\n«k:and» «v:print_tbreak» = pp_print_tbreak std_formatter\n«k:and» «v:set_tab» = pp_set_tab std_formatter\n«k:and» «v:print_tab» = pp_print_tab std_formatter\n«k:and» «v:set_margin» = pp_set_margin std_formatter\n«k:and» «v:get_margin» = pp_get_margin std_formatter\n«k:and» «v:set_max_indent» = pp_set_max_indent std_formatter\n«k:and» «v:get_max_indent» = pp_get_max_indent std_formatter\n«k:and» «v:set_max_boxes» = pp_set_max_boxes std_formatter\n«k:and» «v:get_max_boxes» = pp_get_max_boxes std_formatter\n«k:and» «v:over_max_boxes» = pp_over_max_boxes std_formatter\n«k:and» «v:set_ellipsis_text» = pp_set_ellipsis_text std_formatter\n«k:and» «v:get_ellipsis_text» = pp_get_ellipsis_text std_formatter\n«k:and» «f:set_formatter_out_channel» («v:channel» : «t:out_channel») =\n pp_set_formatter_out_channel std_formatter channel\n«k:and» «v:set_formatter_out_functions» =\n pp_set_formatter_out_functions std_formatter\n«k:and» «v:get_formatter_out_functions» =\n pp_get_formatter_out_functions std_formatter\n«k:and» «v:set_formatter_output_functions» =\n pp_set_formatter_output_functions std_formatter\n«k:and» «v:get_formatter_output_functions» =\n pp_get_formatter_output_functions std_formatter\n«k:and» «v:set_all_formatter_output_functions» =\n pp_set_all_formatter_output_functions std_formatter\n«k:and» «v:get_all_formatter_output_functions» =\n pp_get_all_formatter_output_functions std_formatter\n«k:and» «v:set_formatter_tag_functions» =\n pp_set_formatter_tag_functions std_formatter\n«k:and» «v:get_formatter_tag_functions» =\n pp_get_formatter_tag_functions std_formatter\n«k:and» «v:set_print_tags» = pp_set_print_tags std_formatter\n«k:and» «v:get_print_tags» = pp_get_print_tags std_formatter\n«k:and» «v:set_mark_tags» = pp_set_mark_tags std_formatter\n«k:and» «v:get_mark_tags» = pp_get_mark_tags std_formatter\n«k:and» «v:set_tags» = pp_set_tags std_formatter\n \n«x:(**************************************************************\n\n Printf implementation.\n\n **************************************************************)»\n«k:module» «t:Sformat» = Printf.Sformat\n \n«k:module» «t:Tformat» = Printf.CamlinternalPr.Tformat\n \n«x:(* Error messages when processing formats. *)»\n«x:(* Trailer: giving up at character number ... *)»\n«k:let» «f:giving_up» «v:mess» «v:fmt» «v:i» =\n sprintf «s:\"Format.fprintf: %s ``%s'', giving up at character number %d%s\"»\n mess (Sformat.to_string fmt) i\n («k:if» i < Sformat.length fmt\n «k:then» sprintf «s:\" (%c).\"» (Sformat.get fmt i)\n «k:else» sprintf «s:\"%c\"» «s:'.'»)\n \n«x:(* When an invalid format deserves a special error explanation. *)»\n«k:let» «f:format_invalid_arg» «v:mess» «v:fmt» «v:i» = invalid_arg (giving_up mess fmt i)\n \n«x:(* Standard invalid format. *)»\n«k:let» «f:invalid_format» «v:fmt» «v:i» = format_invalid_arg «s:\"bad format\"» fmt i\n \n«x:(* Cannot find a valid integer into that format. *)»\n«k:let» «f:invalid_integer» «v:fmt» «v:i» =\n invalid_arg (giving_up «s:\"bad integer specification\"» fmt i)\n \n«x:(* Finding an integer size out of a sub-string of the format. *)»\n«k:let» «f:format_int_of_string» «v:fmt» «v:i» «v:s» =\n «k:let» «v:sz» = «k:try» int_of_string s «k:with» «:fsharp-ui-operator-face:|» Failure _ -> invalid_integer fmt i\n «k:in» size_of_int sz\n \n«x:(* Getting strings out of buffers. *)»\n«k:let» «f:get_buffer_out» «v:b» = «k:let» s = Buffer.contents b «k:in» (Buffer.reset b; s)\n \n«x:(* [ppf] is supposed to be a pretty-printer that outputs to buffer [b]:\n to extract the contents of [ppf] as a string we flush [ppf] and get the\n string out of [b]. *)»\n«k:let» «f:string_out» «v:b» «v:ppf» = (pp_flush_queue ppf «k:false»; get_buffer_out b)\n \n«x:(* Applies [printer] to a formatter that outputs on a fresh buffer,\n then returns the resulting material. *)»\n«k:let» «f:exstring» «v:printer» «v:arg» =\n «k:let» «v:b» = Buffer.create 512 «k:in»\n «k:let» «v:ppf» = formatter_of_buffer b «k:in» (printer ppf arg; string_out b ppf)\n \n«x:(* To turn out a character accumulator into the proper string result. *)»\n«k:let» «f:implode_rev» «v:s0» = «k:function»\n «:fsharp-ui-operator-face:|» [] -> s0\n «:fsharp-ui-operator-face:|» l -> String.concat «s:\"\"» (List.rev (s0 :: l))\n \n«x:(* [mkprintf] is the printf-like function generator: given the\n - [to_s] flag that tells if we are printing into a string,\n - the [get_out] function that has to be called to get a [ppf] function to\n output onto,\n it generates a [kprintf] function that takes as arguments a [k]\n continuation function to be called at the end of formatting,\n and a printing format string to print the rest of the arguments\n according to the format string.\n Regular [fprintf]-like functions of this module are obtained via partial\n applications of [mkprintf]. *)»\n«k:let» «f:mkprintf» «v:to_s» «v:get_out» =\n «k:let» «k:rec» «f:kprintf» «v:k» «v:fmt» =\n «k:let» «v:len» = Sformat.length fmt «k:in»\n «k:let» «f:kpr» «v:fmt» «v:v» =\n «k:let» «v:ppf» = get_out fmt «k:in»\n «k:let» «v:print_as» = ref None «k:in»\n «k:let» «k:rec» «f:pp_print_as_char» «v:c» =\n «k:match» !print_as «k:with»\n «:fsharp-ui-operator-face:|» None -> pp_print_char ppf c\n «:fsharp-ui-operator-face:|» Some size ->\n (pp_print_as_size ppf size (String.make 1 c); print_as := None)\n «k:and» «f:pp_print_as_string» «v:s» =\n «k:match» !print_as «k:with»\n «:fsharp-ui-operator-face:|» None -> pp_print_string ppf s\n «:fsharp-ui-operator-face:|» Some size -> (pp_print_as_size ppf size s; print_as := None) «k:in»\n «k:let» «k:rec» «f:doprn» «v:n» «v:i» =\n «k:if» i >= len\n «k:then» Obj.magic (k ppf)\n «k:else»\n («k:match» Sformat.get fmt i «k:with»\n «:fsharp-ui-operator-face:|» «s:'%'» ->\n Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f\n cont_m\n «:fsharp-ui-operator-face:|» «s:'@'» ->\n «k:let» «v:i» = succ i\n «k:in»\n «k:if» i >= len\n «k:then» invalid_format fmt i\n «k:else»\n («k:match» Sformat.get fmt i «k:with»\n «:fsharp-ui-operator-face:|» «s:'['» -> do_pp_open_box ppf n (succ i)\n «:fsharp-ui-operator-face:|» «s:']'» -> (pp_close_box ppf (); doprn n (succ i))\n «:fsharp-ui-operator-face:|» «s:'{'» -> do_pp_open_tag ppf n (succ i)\n «:fsharp-ui-operator-face:|» «s:'}'» -> (pp_close_tag ppf (); doprn n (succ i))\n «:fsharp-ui-operator-face:|» «s:' '» -> (pp_print_space ppf (); doprn n (succ i))\n «:fsharp-ui-operator-face:|» «s:','» -> (pp_print_cut ppf (); doprn n (succ i))\n «:fsharp-ui-operator-face:|» «s:'?'» -> (pp_print_flush ppf (); doprn n (succ i))\n «:fsharp-ui-operator-face:|» «s:'.'» -> (pp_print_newline ppf (); doprn n (succ i))\n «:fsharp-ui-operator-face:|» «s:'\\n'» -> (pp_force_newline ppf (); doprn n (succ i))\n «:fsharp-ui-operator-face:|» «s:';'» -> do_pp_break ppf n (succ i)\n «:fsharp-ui-operator-face:|» «s:'<'» ->\n «k:let» «f:got_size» «v:size» «v:n» «v:i» =\n (print_as := Some size; doprn n (skip_gt i))\n «k:in» get_int n (succ i) got_size\n «:fsharp-ui-operator-face:|» («s:'@'» «:fsharp-ui-operator-face:|» «s:'%'» «k:as» c) ->\n (pp_print_as_char c; doprn n (succ i))\n «:fsharp-ui-operator-face:|» _ -> invalid_format fmt i)\n «:fsharp-ui-operator-face:|» c -> (pp_print_as_char c; doprn n (succ i)))\n «k:and» «f:cont_s» «v:n» «v:s» «v:i» = (pp_print_as_string s; doprn n i)\n «k:and» «f:cont_a» «v:n» «v:printer» «v:arg» «v:i» =\n («k:if» to_s\n «k:then»\n pp_print_as_string\n ((Obj.magic printer : «t:unit» -> _ -> string) () arg)\n «k:else» printer ppf arg;\n doprn n i)\n «k:and» «f:cont_t» «v:n» «v:printer» «v:i» =\n («k:if» to_s\n «k:then» pp_print_as_string ((Obj.magic printer : «t:unit» -> string) ())\n «k:else» printer ppf;\n doprn n i)\n «k:and» «f:cont_f» «v:n» «v:i» = (pp_print_flush ppf (); doprn n i)\n «k:and» «f:cont_m» «v:n» «v:sfmt» «v:i» = kprintf (Obj.magic («k:fun» «v:_» -> doprn n i)) sfmt\n «k:and» «f:get_int» «v:n» «v:i» «v:c» =\n «k:if» i >= len\n «k:then» invalid_integer fmt i\n «k:else»\n («k:match» Sformat.get fmt i «k:with»\n «:fsharp-ui-operator-face:|» «s:' '» -> get_int n (succ i) c\n «:fsharp-ui-operator-face:|» «s:'%'» ->\n «k:let» «k:rec» «f:cont_s» «v:n» «v:s» «v:i» = c (format_int_of_string fmt i s) n i\n «k:and» «f:cont_a» «v:_n» «v:_printer» «v:_arg» «v:i» = invalid_integer fmt i\n «k:and» «f:cont_t» «v:_n» «v:_printer» «v:i» = invalid_integer fmt i\n «k:and» «f:cont_f» «v:_n» «v:i» = invalid_integer fmt i\n «k:and» «f:cont_m» «v:_n» «v:_sfmt» «v:i» = invalid_integer fmt i\n «k:in»\n Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f\n cont_m\n «:fsharp-ui-operator-face:|» _ ->\n «k:let» «k:rec» «f:get» «v:j» =\n «k:if» j >= len\n «k:then» invalid_integer fmt j\n «k:else»\n («k:match» Sformat.get fmt j «k:with»\n «:fsharp-ui-operator-face:|» x «k:when» x >= «s:'0'» && x <= «s:'9'» ->\n get (succ j)\n «:fsharp-ui-operator-face:|» «s:'-'» -> get (succ j)\n «:fsharp-ui-operator-face:|» _ ->\n «k:let» «v:size» =\n «k:if» j = i\n «k:then» size_of_int 0\n «k:else»\n («k:let» s =\n Sformat.sub fmt (Sformat.index_of_int i)\n (j - i)\n «k:in» format_int_of_string fmt j s)\n «k:in» c size n j)\n «k:in» get i)\n «k:and» «f:skip_gt» «v:i» =\n «k:if» i >= len\n «k:then» invalid_format fmt i\n «k:else»\n («k:match» Sformat.get fmt i «k:with»\n «:fsharp-ui-operator-face:|» «s:' '» -> skip_gt (succ i)\n «:fsharp-ui-operator-face:|» «s:'>'» -> succ i\n «:fsharp-ui-operator-face:|» _ -> invalid_format fmt i)\n «k:and» «f:get_box_kind» «v:i» =\n «k:if» i >= len\n «k:then» (Pp_box, i)\n «k:else»\n («k:match» Sformat.get fmt i «k:with»\n «:fsharp-ui-operator-face:|» «s:'h'» ->\n «k:let» «v:i» = succ i\n «k:in»\n «k:if» i >= len\n «k:then» (Pp_hbox, i)\n «k:else»\n («k:match» Sformat.get fmt i «k:with»\n «:fsharp-ui-operator-face:|» «s:'o'» ->\n «k:let» «v:i» = succ i\n «k:in»\n «k:if» i >= len\n «k:then» format_invalid_arg «s:\"bad box format\"» fmt i\n «k:else»\n («k:match» Sformat.get fmt i «k:with»\n «:fsharp-ui-operator-face:|» «s:'v'» -> (Pp_hovbox, (succ i))\n «:fsharp-ui-operator-face:|» c ->\n format_invalid_arg\n («s:\"bad box name ho\"» ^ (String.make 1 c))\n fmt i)\n «:fsharp-ui-operator-face:|» «s:'v'» -> (Pp_hvbox, (succ i))\n «:fsharp-ui-operator-face:|» _ -> (Pp_hbox, i))\n «:fsharp-ui-operator-face:|» «s:'b'» -> (Pp_box, (succ i))\n «:fsharp-ui-operator-face:|» «s:'v'» -> (Pp_vbox, (succ i))\n «:fsharp-ui-operator-face:|» _ -> (Pp_box, i))\n «k:and» «f:get_tag_name» «v:n» «v:i» «v:c» =\n «k:let» «k:rec» «f:get» «v:accu» «v:n» «v:i» «v:j» =\n «k:if» j >= len\n «k:then»\n c\n (implode_rev (Sformat.sub fmt (Sformat.index_of_int i) (j - i))\n accu)\n n j\n «k:else»\n («k:match» Sformat.get fmt j «k:with»\n «:fsharp-ui-operator-face:|» «s:'>'» ->\n c\n (implode_rev\n (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) accu)\n n j\n «:fsharp-ui-operator-face:|» «s:'%'» ->\n «k:let» «v:s0» = Sformat.sub fmt (Sformat.index_of_int i) (j - i) «k:in»\n «k:let» «k:rec» «f:cont_s» «v:n» «v:s» «v:i» = get (s :: s0 :: accu) n i i\n «k:and» «f:cont_a» «v:n» «v:printer» «v:arg» «v:i» =\n «k:let» «v:s» =\n «k:if» to_s\n «k:then» (Obj.magic printer : «t:unit» -> _ -> string) () arg\n «k:else» exstring printer arg\n «k:in» get (s :: s0 :: accu) n i i\n «k:and» «f:cont_t» «v:n» «v:printer» «v:i» =\n «k:let» «v:s» =\n «k:if» to_s\n «k:then» (Obj.magic printer : «t:unit» -> string) ()\n «k:else» exstring («k:fun» «v:ppf» () -> printer ppf) ()\n «k:in» get (s :: s0 :: accu) n i i\n «k:and» «f:cont_f» «v:_n» «v:i» =\n format_invalid_arg «s:\"bad tag name specification\"» fmt i\n «k:and» «f:cont_m» «v:_n» «v:_sfmt» «v:i» =\n format_invalid_arg «s:\"bad tag name specification\"» fmt i\n «k:in»\n Tformat.scan_format fmt v n j cont_s cont_a cont_t cont_f\n cont_m\n «:fsharp-ui-operator-face:|» _ -> get accu n i (succ j))\n «k:in» get [] n i i\n «k:and» «f:do_pp_break» «v:ppf» «v:n» «v:i» =\n «k:if» i >= len\n «k:then» (pp_print_space ppf (); doprn n i)\n «k:else»\n («k:match» Sformat.get fmt i «k:with»\n «:fsharp-ui-operator-face:|» «s:'<'» ->\n «k:let» «k:rec» «f:got_nspaces» «v:nspaces» «v:n» «v:i» =\n get_int n i (got_offset nspaces)\n «k:and» «f:got_offset» «v:nspaces» «v:offset» «v:n» «v:i» =\n (pp_print_break ppf (int_of_size nspaces)\n (int_of_size offset);\n doprn n (skip_gt i))\n «k:in» get_int n (succ i) got_nspaces\n «:fsharp-ui-operator-face:|» _c -> (pp_print_space ppf (); doprn n i))\n «k:and» «f:do_pp_open_box» «v:ppf» «v:n» «v:i» =\n «k:if» i >= len\n «k:then» (pp_open_box_gen ppf 0 Pp_box; doprn n i)\n «k:else»\n («k:match» Sformat.get fmt i «k:with»\n «:fsharp-ui-operator-face:|» «s:'<'» ->\n «k:let» («v:kind», «v:i») = get_box_kind (succ i) «k:in»\n «k:let» «f:got_size» «v:size» «v:n» «v:i» =\n (pp_open_box_gen ppf (int_of_size size) kind;\n doprn n (skip_gt i))\n «k:in» get_int n i got_size\n «:fsharp-ui-operator-face:|» _c -> (pp_open_box_gen ppf 0 Pp_box; doprn n i))\n «k:and» «f:do_pp_open_tag» «v:ppf» «v:n» «v:i» =\n «k:if» i >= len\n «k:then» (pp_open_tag ppf «s:\"\"»; doprn n i)\n «k:else»\n («k:match» Sformat.get fmt i «k:with»\n «:fsharp-ui-operator-face:|» «s:'<'» ->\n «k:let» «f:got_name» «v:tag_name» «v:n» «v:i» =\n (pp_open_tag ppf tag_name; doprn n (skip_gt i))\n «k:in» get_tag_name n (succ i) got_name\n «:fsharp-ui-operator-face:|» _c -> (pp_open_tag ppf «s:\"\"»; doprn n i))\n «k:in» doprn (Sformat.index_of_int 0) 0\n «k:in» Tformat.kapr kpr fmt\n «k:in» kprintf\n \n«x:(**************************************************************\n\n Defining [fprintf] and various flavors of [fprintf].\n\n **************************************************************)»\n«k:let» «f:kfprintf» «v:k» «v:ppf» = mkprintf «k:false» («k:fun» «v:_» -> ppf) k\n \n«k:let» «f:ikfprintf» «v:k» «v:ppf» = Tformat.kapr («k:fun» «v:_» «v:_» -> Obj.magic (k ppf))\n \n«k:let» «f:fprintf» «v:ppf» = kfprintf ignore ppf\n \n«k:let» «f:ifprintf» «v:ppf» = ikfprintf ignore ppf\n \n«k:let» «f:printf» «v:fmt» = fprintf std_formatter fmt\n \n«k:let» «f:eprintf» «v:fmt» = fprintf err_formatter fmt\n \n«k:let» «f:ksprintf» «v:k» =\n «k:let» «v:b» = Buffer.create 512 «k:in»\n «k:let» «f:k» «v:ppf» = k (string_out b ppf)\n «k:in» mkprintf «k:true» («k:fun» «v:_» -> formatter_of_buffer b) k\n \n«k:let» «f:sprintf» «v:fmt» = ksprintf («k:fun» «v:s» -> s) fmt\n \n«x:(**************************************************************\n\n Deprecated stuff.\n\n **************************************************************)»\n«k:let» «f:kbprintf» «v:k» «v:b» = mkprintf «k:false» («k:fun» «v:_» -> formatter_of_buffer b) k\n \n«x:(* Deprecated error prone function bprintf. *)»\n«k:let» «f:bprintf» «v:b» = «k:let» «f:k» ppf = pp_flush_queue ppf «k:false» «k:in» kbprintf k b\n \n«x:(* Deprecated alias for ksprintf. *)»\n«k:let» «v:kprintf» = ksprintf\n \n«x:(* Output everything left in the pretty printer queue at end of execution. *)»\n«k:let» «v:_» = at_exit print_flush\n \n" }, { "path": "test/apps/RecordHighlighting/Test.fsx", "content": "type RecordTest1 = { something: int\n another: string }\n\ntype RecordTest2 = { something :int; another :string }\n\ntype RecordTest3 = { something : float; another: float; third :float; }\n\ntype RecordTest4 = {\n something: int\n another: string }\n\ntype RecordTest5 =\n { something: int\n another: string }\n\ntype RecordTest6 =\n {\n something: int\n another: string\n third: Option\n }\n\ntype RecordTest7 =\n {\n something: int\n another: string\n third: int option\n }\n" }, { "path": "test/apps/RecordHighlighting/Test.fsx.faceup", "content": "«k:type» «t:RecordTest1» = { something: «t:int»\n another: «t:string» }\n\n«k:type» «t:RecordTest2» = { something :«t:int»; another :«t:string» }\n\n«k:type» «t:RecordTest3» = { something : «t:float»; another: «t:float»; third :«t:float»; }\n\n«k:type» «t:RecordTest4» = {\n something: «t:int»\n another: «t:string» }\n\n«k:type» «t:RecordTest5» =\n { something: «t:int»\n another: «t:string» }\n\n«k:type» «t:RecordTest6» =\n {\n something: «t:int»\n another: «t:string»\n third: «t:Option»«:fsharp-ui-generic-face:»\n }\n\n«k:type» «t:RecordTest7» =\n {\n something: «t:int»\n another: «t:string»\n third: «t:int option»\n }\n" }, { "path": "test/eglot-fsharp-integration-util.el", "content": ";;; eglot-fsharp-integration-util.el --- Helper for eglot integration tests -*- lexical-binding: t; -*-\n\n;; Copyright (C) 2022-2023 Jürgen Hötzel\n\n;; Author: Jürgen Hötzel \n;; Keywords: processes\n\n;; This program is free software; you can redistribute it and/or modify\n;; it under the terms of the GNU General Public License as published by\n;; the Free Software Foundation, either version 3 of the License, or\n;; (at your option) any later version.\n\n;; This program is distributed in the hope that it will be useful,\n;; but WITHOUT ANY WARRANTY; without even the implied warranty of\n;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n;; GNU General Public License for more details.\n\n;; You should have received a copy of the GNU General Public License\n;; along with this program. If not, see .\n\n;;; Commentary:\n\n;; \n\n;;; Code:\n(require 'edebug)\n\n(cl-defmacro eglot-fsharp--with-timeout (timeout &body body)\n (declare (indent 1) (debug t))\n `(eglot-fsharp--call-with-timeout ,timeout (lambda () ,@body)))\n\n(defun eglot-fsharp--call-with-timeout (timeout fn)\n (let* ((tag (gensym \"eglot-test-timeout\"))\n (timed-out (make-symbol \"timeout\"))\n (timeout-and-message\n (if (listp timeout) timeout\n (list timeout \"waiting for test to finish\")))\n (timeout (car timeout-and-message))\n (message (cadr timeout-and-message))\n (timer)\n (retval))\n (unwind-protect\n (setq retval\n (catch tag\n (setq timer\n (run-with-timer timeout nil\n (lambda ()\n (unless edebug-active\n (throw tag timed-out)))))\n (funcall fn)))\n (cancel-timer timer)\n (when (eq retval timed-out)\n (warn \"Received Events for %s : %s\"\n (file-name-nondirectory (buffer-file-name))\n (with-current-buffer (jsonrpc-events-buffer (eglot-current-server)) (buffer-string)))\n (error \"%s\" (concat \"Timed out \" message))))))\n\n\n(defun eglot-fsharp--find-file-noselect (file &optional noerror)\n (unless (or noerror\n (file-readable-p file)) (error \"%s does not exist\" file))\n (find-file-noselect file))\n\n(defun eglot-fsharp--tests-connect (&optional timeout)\n (let* ((timeout (or timeout 10))\n (eglot-sync-connect t)\n (eglot-connect-timeout timeout))\n (apply #'eglot--connect (eglot--guess-contact))))\n\n(cl-defmacro eglot-fsharp--wait-for ((events-sym &optional (timeout 1) message) args &body body)\n \"Spin until FN match in EVENTS-SYM, flush events after it.\nPass TIMEOUT to `eglot--with-timeout'.\"\n (declare (indent 2) (debug (sexp sexp sexp &rest form)))\n `(eglot-fsharp--with-timeout '(,timeout ,(or message\n (format \"waiting for:\\n%s\" (pp-to-string body))))\n (let ((event\n (cl-loop thereis (cl-loop for json in ,events-sym\n for method = (plist-get json :method)\n when (keywordp method)\n do (plist-put json :method\n (substring\n (symbol-name method)\n 1))\n when (funcall\n (jsonrpc-lambda ,args ,@body) json)\n return (cons json before)\n collect json into before)\n for i from 0\n when (zerop (mod i 5))\n ;; do (eglot--message \"still struggling to find in %s\"\n ;; ,events-sym)\n do\n ;; `read-event' is essential to have the file\n ;; watchers come through.\n (read-event \"[eglot] Waiting a bit...\" nil 0.1)\n (accept-process-output nil 0.1))))\n (setq ,events-sym (cdr event))\n (eglot--message \"Event detected:\\n%s\"\n (pp-to-string (car event))))))\n\n\n(cl-defmacro eglot-fsharp--sniffing ((&key server-requests\n server-notifications\n server-replies\n client-requests\n client-notifications\n client-replies)\n &rest body)\n \"Run BODY saving LSP JSON messages in variables, most recent first.\"\n (declare (indent 1) (debug (sexp &rest form)))\n (let ((log-event-ad-sym (make-symbol \"eglot-fsharp--event-sniff\")))\n `(unwind-protect\n (let ,(delq nil (list server-requests\n server-notifications\n server-replies\n client-requests\n client-notifications\n client-replies))\n (advice-add\n #'jsonrpc--log-event :before\n (lambda (_proc message &optional type)\n (cl-destructuring-bind (&key method id _error &allow-other-keys)\n message\n (let ((req-p (and method id))\n (notif-p method)\n (reply-p id))\n (cond\n ((eq type 'server)\n (cond (req-p ,(when server-requests\n `(push message ,server-requests)))\n (notif-p ,(when server-notifications\n `(push message ,server-notifications)))\n (reply-p ,(when server-replies\n `(push message ,server-replies)))))\n ((eq type 'client)\n (cond (req-p ,(when client-requests\n `(push message ,client-requests)))\n (notif-p ,(when client-notifications\n `(push message ,client-notifications)))\n (reply-p ,(when client-replies\n `(push message ,client-replies)))))))))\n '((name . ,log-event-ad-sym)))\n ,@body)\n (advice-remove #'jsonrpc--log-event ',log-event-ad-sym))))\n\n\n\n(defun eglot-fsharp--sniff-diagnostics (file-name-suffix)\n (eglot-fsharp--sniffing (:server-notifications s-notifs)\n (eglot-fsharp--wait-for (s-notifs 20)\n (&key _id method params &allow-other-keys)\n (and\n (string= method \"textDocument/publishDiagnostics\")\n (string-suffix-p file-name-suffix (plist-get params :uri))))))\n\n(defun eglot-fsharp--sniff-method (method-name)\n (eglot-fsharp--sniffing (:server-notifications s-notifs)\n (eglot-fsharp--wait-for (s-notifs 20)\n (&key _id method params &allow-other-keys)\n (and\n (string= method method-name)))))\n\n(provide 'eglot-fsharp-integration-util)\n;;; integration-util.el ends here\n" }, { "path": "test/expression.fsx", "content": "1 + 1;;\n" }, { "path": "test/fsharp-mode-font-tests.el", "content": ";;; fsharp-mode-font-tests.el --- -*- lexical-binding: t; -*-\n\n(require 'buttercup)\n(require 'fsharp-mode)\n\n(defmacro with-highlighted (src &rest body)\n \"Insert SRC in a temporary fsharp-mode buffer, apply syntax highlighting,\nthen run BODY.\"\n `(with-temp-buffer\n (fsharp-mode)\n (insert ,src)\n (goto-char (point-min))\n ;; Ensure we've syntax-highlighted the whole buffer.\n (if (fboundp 'font-lock-ensure)\n (font-lock-ensure)\n (with-no-warnings\n (font-lock-fontify-buffer)))\n ,@body))\n\n(defun str-face (op)\n (goto-char (point-min))\n (search-forward op)\n (left-char 2)\n (face-at-point))\n\n(describe \"When locking operators\"\n (it \"uses ui operator face for pipes\"\n (with-highlighted \"<<| |>> |> ||> |||> <| <|| <||| <|> <<|!\"\n (should (equal (str-face \" |> \") 'fsharp-ui-operator-face))\n (should (equal (str-face \" ||> \") 'fsharp-ui-operator-face))\n (should (equal (str-face \" |||> \") 'fsharp-ui-operator-face))\n (should (equal (str-face \" <| \") 'fsharp-ui-operator-face))\n (should (equal (str-face \" <|| \") 'fsharp-ui-operator-face))\n (should (equal (str-face \" <||| \") 'fsharp-ui-operator-face)))))\n\n(describe \"When locking operators\"\n (it \"uses ui generic face for custom operators containing pipes\"\n (with-highlighted \"<<| |>> |> ||> |||> <| <|| <||| <|> <<|!\"\n (should (equal (str-face \"<<| \") 'fsharp-ui-generic-face))\n (should (equal (str-face \" |>> \") 'fsharp-ui-generic-face))\n (should (equal (str-face \" <|> \") 'fsharp-ui-generic-face))\n (should (equal (str-face \" <<|!\") 'fsharp-ui-generic-face)))))\n" }, { "path": "test/fsharp-mode-structure-tests.el", "content": ";;; fsharp-mode-structure-tests.el --- -*- lexical-binding: t; -*-\n\n(require 'buttercup)\n\n(require 'fsharp-mode)\n(require 'fsharp-mode-structure)\n\n(defvar fsharp-struct-test-files-dir \"test/StructureTest/\")\n\n;;-------------------------------- Regex Tests --------------------------------;;\n\n(ert-deftest fsharp-stringlit-re-test ())\n\n;;--------------------------- Structure Navigation ---------------------------;;\n;; TODO[gastove|2019-10-31] This function turns out to be incredibly broken! It\n;; wont move past the final line of _most_ multi-line expressions. Wonderful.\n;;\n;; This will get fixed in the next PR.\n;; (ert-deftest fsharp-goto-beyond-final-line-test ()\n;; (let ((blocks-file (file-truename (concat fsharp-struct-test-files-dir \"Blocks.fs\"))))\n;; (using-file blocks-file\n;; ;; A single-line expression\n;; (goto-char 1)\n;; (fsharp-goto-beyond-final-line)\n;; (should (eq (point) 19))\n\n;; ;; A multi-line expression using a pipe. We should wind up in the same\n;; ;; place whether we start at the beginning or the end of the expression.\n;; (goto-char 20)\n;; (fsharp-goto-beyond-final-line)\n;; (should (eq (point) 88))\n;; (goto-char 46)\n;; (fsharp-goto-beyond-final-line)\n;; (should (eq (point) 88))\n\n;; ;; A multi-line discriminated union.\n;; (goto-char 89)\n;; (fsharp-goto-beyond-final-line)\n;; (should (eq (point) 146))\n;; (goto-char 122)\n;; (fsharp-goto-beyond-final-line)\n;; (should (eq (point) 146))\n\n;; ;; A function using an if/else block\n;; (goto-char 147)\n;; (fsharp-goto-beyond-final-line)\n;; (should (eq (point) 218))\n;; (goto-char 171)\n;; (fsharp-goto-beyond-final-line)\n;; (should (eq (point) 218))\n;; )))\n\n;;-------------------------------- Predicates --------------------------------;;\n\n(describe \"The `fsharp-backslash-continuation-line-p' predicate\"\n (it \"returns true when we expect it to\"\n (let ((file (file-truename (concat fsharp-struct-test-files-dir \"ContinuationLines.fs\"))))\n (with-current-buffer (find-file-noselect file)\n\t (beginning-of-buffer)\n\t (should (eq (fsharp--hanging-operator-continuation-line-p) nil))\n\t (forward-line 1)\n\t (should (eq (fsharp--hanging-operator-continuation-line-p) nil))\n\t (forward-line 5)\n\t (should (eq (fsharp--hanging-operator-continuation-line-p) t))))))\n\n(describe \"The `fsharp-in-literal-p'\"\n (it \"return non-nil in both strings and comments?\"\n (let ((literals-file (file-truename (concat fsharp-struct-test-files-dir \"Literals.fs\"))))\n (with-current-buffer (find-file-noselect literals-file)\n\t ;; Comments\n\t (goto-char 3)\n\t (should (eq (fsharp-in-literal-p) 'comment))\n\t (goto-char 642)\n\t (should (eq (fsharp-in-literal-p) 'comment))\n\t (goto-char 968)\n\t (should (eq (fsharp-in-literal-p) 'comment))\n\t (goto-char 1481)\n\t (should (eq (fsharp-in-literal-p) 'comment))\n\t (goto-char 2124)\n\t (should (eq (fsharp-in-literal-p) 'comment))\n\t ;; String literals\n\t (goto-char 2717)\n\t (should (eq (fsharp-in-literal-p) 'string))\n\t ;; This string contains an inner, backslash-escaped string.\n\t ;; First, with point outside the backslash-escaped string:\n\t (goto-char 2759)\n\t (should (eq (fsharp-in-literal-p) 'string))\n\t ;; ...and now with point inside it\n\t (goto-char 2774)\n\t (should (eq (fsharp-in-literal-p) 'string))\n\t ;; Inside triple-quoted strings\n\t (goto-char 2835)\n\t (should (eq (fsharp-in-literal-p) 'string))\n\t (goto-char 2900)\n\t (should (eq (fsharp-in-literal-p) 'string))))))\n\n;; NOTE[gastove|2019-10-31] I am entirely convinced this doesn't work precisely\n;; as it should, because it depends on `fsharp-goto-beyond-final-line', which I\n;; am positive is buggy.\n;;\n;; Udate: yep! It's buggy! Will uncomment and fix in the next PR.\n;; (ert-deftest fsharp-statement-opens-block-p-test ()\n;; \"Does `fsharp-statement-opens-block-p' correctly detect block-opening statements?\"\n;; (let ((blocks-file (file-truename (concat fsharp-struct-test-files-dir \"Blocks.fs\"))))\n;; (using-file blocks-file\n;; (goto-char 1)\n;; (should-not (fsharp-statement-opens-block-p))\n;; (goto-char 20)\n;; (should (fsharp-statement-opens-block-p))\n;; (goto-char 89)\n;; (should (fsharp-statement-opens-block-p)))))\n\n;;--------------------- Nesting and Indentation Functions ---------------------;;\n\n(describe \"The `fsharp-nesting-level' function\"\n (it \"returns nil when we expect it to\"\n (with-temp-buffer\n (insert \"let x = 5\")\n (end-of-buffer)\n (should (eq (fsharp-nesting-level) nil)))))\n\n(describe \"The `fsharp-nesting-level' function\"\n :var ((file (file-truename (concat fsharp-struct-test-files-dir \"Nesting.fs\"))))\n (it \"correctly return the point position of the opening pair closest to point\"\n ;; The character positions use here reference characters noted in comments in Nesting.fs\n ;; Test a normal list\n (with-current-buffer (find-file-noselect file)\n (goto-char 645)\n (should (eq (fsharp-nesting-level) 640)))\n\n ;; Get the opening bracket of an inner list from a single-line nested list\n (with-current-buffer (find-file-noselect file)\n (goto-char 717)\n (should (eq (fsharp-nesting-level) 706)))\n\n ;; Opening bracket for a multi-line non-nested list\n (with-current-buffer (find-file-noselect file)\n (goto-char 795)\n (should (eq (fsharp-nesting-level) 777)))\n\n ;; Inner most opening bracket for a multi-line multi-nested list\n (with-current-buffer (find-file-noselect file)\n (goto-char 960)\n (should (eq (fsharp-nesting-level) 955)))\n ;; Middle opening bracket for same list as previous\n (with-current-buffer (find-file-noselect file)\n (goto-char 954)\n (should (eq (fsharp-nesting-level) 953)))\n (with-current-buffer (find-file-noselect file)\n (goto-char 974)\n (should (eq (fsharp-nesting-level) 953)))\n ;; Outermost opening bracket for same list\n (with-current-buffer (find-file-noselect file)\n (goto-char 977)\n (should (eq (fsharp-nesting-level) 947)))\n\n ;; Basic Async form, should return the opening {\n (with-current-buffer (find-file-noselect file)\n (goto-char 1088)\n (should (eq (fsharp-nesting-level) 1060)))\n ;; Same async form, inner async call\n (with-current-buffer (find-file-noselect file)\n (goto-char 1129)\n (should (eq (fsharp-nesting-level) 1121)))\n\n ;; Lambda, wrapped in parens, should return the opening (\n (with-current-buffer (find-file-noselect file)\n (goto-char 1238)\n (should (eq (fsharp-nesting-level) 1208)))))\n\n\n(describe \"The `fsharp--compute-indentaiton-open-bracket'\"\n :var ((file (file-truename (concat fsharp-struct-test-files-dir \"BracketIndent.fs\"))))\n (it \"returns the correct indentation in a variety of cases\"\n (with-current-buffer (find-file-noselect file)\n ;; Opening bracket on same line as let, elements on same line; test element\n (goto-char 44)\n (let* ((nesting-level (fsharp-nesting-level))\n\t (indent-at-point (fsharp--compute-indentation-open-bracket nesting-level)))\n\t ;; The value we expect\n\t (should (eq indent-at-point 18))\n\t ;; Both entrypoints should have the same answer\n\t (should (eq indent-at-point (fsharp-compute-indentation t))))\n\n ;; Opening bracket on same line as let, elements on same line; test newline\n (goto-char 81)\n (let* ((nesting-level (fsharp-nesting-level))\n\t (indent-at-point (fsharp--compute-indentation-open-bracket nesting-level)))\n\t ;; The value we expect\n\t (should (eq indent-at-point 18))\n\t ;; Both entrypoints should have the same answer\n\t (should (eq indent-at-point (fsharp-compute-indentation t))))\n\n ;; Opening bracket on same line as let, elements on new line; test element\n (goto-char 148)\n (let* ((nesting-level (fsharp-nesting-level))\n\t (indent-at-point (fsharp--compute-indentation-open-bracket nesting-level)))\n\t (should (eq indent-at-point 4))\n\t (should (eq indent-at-point (fsharp-compute-indentation t))))\n\n ;; Opening bracket on same line as let, elements on new line; test newline\n (goto-char 155)\n (let* ((nesting-level (fsharp-nesting-level))\n\t (indent-at-point (fsharp--compute-indentation-open-bracket nesting-level)))\n\t (should (eq indent-at-point 4))\n\t (should (eq indent-at-point (fsharp-compute-indentation t))))\n\n ;; Opening bracket on own line; test element\n (goto-char 231)\n (let* ((nesting-level (fsharp-nesting-level))\n\t (indent-at-point (fsharp--compute-indentation-open-bracket nesting-level)))\n\t (should (eq indent-at-point 6))\n\t (should (eq indent-at-point (fsharp-compute-indentation t))))\n\n ;; Opening bracket on own line; test newline\n (goto-char 236)\n (let* ((nesting-level (fsharp-nesting-level))\n\t (indent-at-point (fsharp--compute-indentation-open-bracket nesting-level)))\n\t (should (eq indent-at-point 6))\n\t (should (eq indent-at-point (fsharp-compute-indentation t)))))))\n\n\n(describe \"The `fsharp--compute-indentation-continuation-line' function\"\n :var ((continuation-line \"let x = 5 +\"))\n (it \"indents correctly\"\n (with-temp-buffer\n (fsharp-mode)\n (insert continuation-line)\n (fsharp-newline-and-indent)\n (should (eq (fsharp--compute-indentation-continuation-line) 8))\n (should (eq (fsharp--compute-indentation-continuation-line) (fsharp-compute-indentation t))))))\n\n\n(describe \"The `fsharp-compute-indentation-relative-to-previous' function'\"\n :var ((file (concat fsharp-struct-test-files-dir \"Relative.fs\")))\n (it \"indents correctly releative to previous line\"\n ;; Discriminated unions\n (with-current-buffer (find-file-noselect file)\n (goto-char 57)\n (should (eq (fsharp--compute-indentation-relative-to-previous t) 4))\n (should (eq (fsharp--compute-indentation-relative-to-previous t)\n\t\t (fsharp-compute-indentation t)))\n\n ;; If/Else blocks\n ;; if an if then are on the same line, the next line is indented\n (goto-char 96)\n (should (eq (fsharp--compute-indentation-relative-to-previous t) 4))\n (should (eq (fsharp--compute-indentation-relative-to-previous t)\n\t\t (fsharp-compute-indentation t)))\n\n ;; An else is not indented further; *however*, the indentation relative to\n ;; previous will be 4, but `fsharp-compute-indentation' will return 0\n ;; because the previous line is not a continuation line.\n ;;\n ;; However! This test case doesn't currently work. Indentation code\n ;; produces indent of 0, but the compute indentation functions proudce an\n ;; indent of 4, which is wrong.\n ;;\n ;; (goto-char 124)\n ;; (should (eq (fsharp--compute-indentation-relative-to-previous t) 4))\n ;; (should-not (eq (fsharp--compute-indentation-relative-to-previous t)\n ;; (fsharp-compute-indentation t)))\n\n ;; when a then is on its own line, the next line is indented\n (goto-char 154)\n (should (eq (fsharp--compute-indentation-relative-to-previous t) 4))\n (should (eq (fsharp--compute-indentation-relative-to-previous t)\n\t\t (fsharp-compute-indentation t)))\n ;; likewise an else\n (goto-char 180)\n (should (eq (fsharp--compute-indentation-relative-to-previous t) 4))\n (should (eq (fsharp--compute-indentation-relative-to-previous t)\n\t\t (fsharp-compute-indentation t))))))\n\n(describe \"The `fsharp-compute-indentation'\"\n :var ((file (concat fsharp-struct-test-files-dir \"BracketIndent.fs\")))\n (it \"indents on the first line after opening bracket\"\n (with-current-buffer (find-file-noselect file)\n (goto-char (point-min))\n (search-forward-regexp \"let formatTwo = \\\\[\\n\")\n (should (eq (fsharp-compute-indentation t) fsharp-indent-offset)))))\n" }, { "path": "test/fsi-tests.el", "content": ";;; fsi-tests.el --- Tests for F# interactive -*- lexical-binding: t; -*-\n\n;; Copyright (C) 2022-2023 Jürgen Hötzel\n\n;; Author: Jürgen Hötzel \n;; Keywords: processes\n\n;; This program is free software; you can redistribute it and/or modify\n;; it under the terms of the GNU General Public License as published by\n;; the Free Software Foundation, either version 3 of the License, or\n;; (at your option) any later version.\n\n;; This program is distributed in the hope that it will be useful,\n;; but WITHOUT ANY WARRANTY; without even the implied warranty of\n;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n;; GNU General Public License for more details.\n\n;; You should have received a copy of the GNU General Public License\n;; along with this program. If not, see .\n\n;;; Commentary:\n\n;; \n\n;;; Code:\n\n(load \"project\") ;Emacs 27 workaround: https://github.com/joaotavora/eglot/issues/549\n(require 'buttercup)\n(require 'fsharp-mode)\n\n(defun fsi-tests-wait-for-regex (timeout regexp)\n (let ((start-time (float-time)))\n (while (and (< (- (float-time) start-time) timeout)\n (not (progn (goto-char (point-min)) (search-forward-regexp regexp nil t))))\n (if (accept-process-output (get-buffer-process (current-buffer)) 0.2)\n (message \"[FSI Interactive] received output...\")\n (message \"[FSI Interactive] waiting for output...\")))))\n\n\n(describe \"F# interactive\"\n :before-all (run-fsharp inferior-fsharp-program)\n :before-each (with-current-buffer (get-buffer inferior-fsharp-buffer-name)\n (comint-clear-buffer))\n (it \"can eval expressions\"\n (with-current-buffer (find-file-noselect \"test/expression.fsx\")\n (fsharp-eval-region (point-min) (point-max))\n (with-current-buffer (get-buffer inferior-fsharp-buffer-name)\n (fsi-tests-wait-for-regex 25 \"it: int = 2$\")\n (let ((result (match-string-no-properties 0)))\n (expect result :to-equal \"it: int = 2\")))))\n (it \"can load nuget references\"\n (let ((timeout 50)\n (fsx-file \"test/nuget.fsx\"))\n (with-current-buffer (find-file-noselect fsx-file)\n (fsharp-load-buffer-file)\n (with-current-buffer (get-buffer inferior-fsharp-buffer-name)\n (fsi-tests-wait-for-regex 25 \"xxx:\\\\(.*\\\\):xxx\")\n (let ((json-str (match-string-no-properties 1)))\n (unless json-str\n (warn \"FSI output doesn't contain marker: %s\" (buffer-substring-no-properties (point-min) (point-max))))\n (expect json-str :to-equal \"{\\\"X\\\":2,\\\"Y\\\":\\\"Hello\\\"}\")))))))\n\n(provide 'fsi-tests)\n;;; fsi-tests.el ends here\n" }, { "path": "test/integration-tests.el", "content": ";;; integration-tests.el --- -*- lexical-binding: t; -*-\n\n;; Copyright (C) 2019-2023 Jürgen Hötzel\n\n;; Author: Jürgen Hötzel \n;; Keywords: abbrev, abbrev\n\n;; This program is free software; you can redistribute it and/or modify\n;; it under the terms of the GNU General Public License as published by\n;; the Free Software Foundation, either version 3 of the License, or\n;; (at your option) any later version.\n\n;; This program is distributed in the hope that it will be useful,\n;; but WITHOUT ANY WARRANTY; without even the implied warranty of\n;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n;; GNU General Public License for more details.\n\n;; You should have received a copy of the GNU General Public License\n;; along with this program. If not, see .\n\n;;; Commentary:\n\n;; This file is part of fsharp-mode\n\n;;; Code:\n\n(load \"project\") ;Emacs 27 workaround: https://github.com/joaotavora/eglot/issues/549\n(require 'buttercup)\n(require 'eglot-fsharp)\n(load \"test/eglot-fsharp-integration-util.el\")\n\n;; FIXME/HELP WANTED: fsautocomplete process don't seem to terminate on windows (Access denied when trying to install\n;; different version)\n(unless (eq system-type 'windows-nt)\n (describe \"F# LSP Installation\"\n :before-all (setq latest-version (eglot-fsharp--latest-version))\n (it \"succeeds using version 0.77.2\"\n (eglot-fsharp--maybe-install \"0.77.2\")\n (expect (eglot-fsharp--installed-version) :to-equal \"0.77.2\"))\n (it (format \"succeeds using latest version: %s)\" latest-version)\n (eglot-fsharp--maybe-install)\n (expect (eglot-fsharp--installed-version) :to-equal latest-version))))\n\n(describe \"F# LSP Client\"\n :before-all (progn (setq latest-version (eglot-fsharp--latest-version))\n (with-temp-buffer (unless (zerop (process-file \"dotnet\" nil (current-buffer) nil \"restore\" \"test/Test1\"))\n (signal 'file-error (buffer-string))))\n (eglot-fsharp--maybe-install)\n (with-current-buffer (eglot-fsharp--find-file-noselect \"test/Test1/FileTwo.fs\")\n (eglot-fsharp--tests-connect 10)\n (eglot-fsharp--sniff-method \"fsharp/notifyWorkspace\")))\n\n (it \"Can be invoked\"\n ;; FIXME: Should use dotnet tool run\n (expect (process-file (eglot-fsharp--path-to-server) nil nil nil \"--version\")\n :to-equal 0))\n (it \"is enabled on F# Files\"\n (with-current-buffer (eglot-fsharp--find-file-noselect \"test/Test1/FileTwo.fs\")\n (expect (type-of (eglot--current-server-or-lose)) :to-be 'eglot-fsautocomplete)))\n (it \"shows flymake errors\"\n (with-current-buffer (eglot-fsharp--find-file-noselect \"test/Test1/Error.fs\")\n (flymake-mode t)\n (flymake-start)\n (eglot-fsharp--sniff-diagnostics \"test/Test1/Error.fs\")\n (goto-char (point-min))\n (search-forward \"nonexisting\")\n (insert \"x\")\n (eglot--signal-textDocument/didChange)\n (flymake-goto-next-error 1 '() t)\n (expect (face-at-point) :to-be 'flymake-error )))\n (it \"provides completion\"\n (with-current-buffer (eglot-fsharp--find-file-noselect \"test/Test1/FileTwo.fs\")\n (expect (plist-get (eglot--capabilities (eglot--current-server-or-lose)) :completionProvider) :not :to-be nil)))\n (it \"completes function in other modules\"\n (with-current-buffer (eglot-fsharp--find-file-noselect \"test/Test1/Program.fs\")\n (search-forward \"X.func\")\n (delete-char -3)\n (completion-at-point)\n (expect (looking-back \"X\\\\.func\") :to-be t)))\n (it \"finds definition in pervasives\"\n (with-current-buffer (eglot-fsharp--find-file-noselect \"test/Test1/Program.fs\")\n (search-forward \"printfn\")\n (expect (current-word) :to-equal \"printfn\") ;sanity check\n (call-interactively #'xref-find-definitions)\n (expect (file-name-nondirectory (buffer-file-name)) :to-equal \"fslib-extra-pervasives.fs\")))\n (it \"finds definitions in other files of Project\"\n (with-current-buffer (eglot-fsharp--find-file-noselect \"test/Test1/Program.fs\")\n (goto-char 150)\n (expect (current-word) :to-equal \"NewObjectType\") ;sanity check\n (call-interactively #'xref-find-definitions)\n (expect (file-name-nondirectory (buffer-file-name)) :to-equal \"FileTwo.fs\"))))\n\n\n(provide 'integration-tests)\n;;; integration-tests.el ends here\n" }, { "path": "test/nuget.fsx", "content": "#r \"nuget: Newtonsoft.Json\";;\nopen Newtonsoft.Json;;\n\nlet o = {| X = 2; Y = \"Hello\" |};;\n\nprintfn \"xxx:%s:xxx\" (JsonConvert.SerializeObject o);;\n" } ]