├── test ├── FindSlnData │ ├── bar.sln │ ├── sln │ │ └── foo.sln │ ├── test.fsproj │ └── noproj │ │ └── test.fs ├── expression.fsx ├── CompileCommandData │ ├── noproj │ │ └── test.fs │ ├── proj │ │ ├── Makefile │ │ ├── test.fs │ │ └── test.fsproj │ └── Directory With Spaces │ │ ├── proj │ │ ├── test.fs │ │ └── test.fsproj │ │ └── noproj │ │ └── test.fs ├── Test1 │ ├── Error.fs │ ├── NoProject.fs │ ├── Pervasive.fs │ ├── Script.fsx │ ├── FileTwo.fs │ ├── Program.fs │ └── Test1.fsproj ├── StructureTest │ ├── ContinuationLines.fs │ ├── Blocks.fs │ ├── BracketIndent.fs │ ├── Relative.fs │ ├── Nesting.fs │ └── Literals.fs ├── Test2 │ ├── Main.fs │ └── Test2.fsproj ├── nuget.fsx ├── apps │ ├── RecordHighlighting │ │ ├── Test.fsx │ │ └── Test.fsx.faceup │ ├── FQuake3 │ │ ├── NativeMappings.fs │ │ └── NativeMappings.fs.faceup │ └── FSharp.Compatibility │ │ └── Format.fs ├── fsharp-mode-font-tests.el ├── fsi-tests.el ├── integration-tests.el ├── eglot-fsharp-integration-util.el └── fsharp-mode-structure-tests.el ├── .dir-locals.el ├── .gitignore ├── .github ├── pull_request_template.md └── workflows │ └── test.yml ├── Eldev ├── ISSUE_TEMPLATE.md ├── fsharp-mode-util.el ├── README.org ├── inf-fsharp-mode.el ├── CHANGELOG.md ├── eglot-fsharp.el ├── LICENSE ├── fsharp-mode.el └── fsharp-mode-font.el /test/FindSlnData/bar.sln: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/FindSlnData/sln/foo.sln: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/FindSlnData/test.fsproj: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/FindSlnData/noproj/test.fs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/expression.fsx: -------------------------------------------------------------------------------- 1 | 1 + 1;; 2 | -------------------------------------------------------------------------------- /test/CompileCommandData/noproj/test.fs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/CompileCommandData/proj/Makefile: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/CompileCommandData/proj/test.fs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/CompileCommandData/proj/test.fsproj: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/CompileCommandData/Directory With Spaces/proj/test.fs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/CompileCommandData/Directory With Spaces/noproj/test.fs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/CompileCommandData/Directory With Spaces/proj/test.fsproj: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/Test1/Error.fs: -------------------------------------------------------------------------------- 1 | module Error 2 | 3 | let x = nonexisting() 4 | 5 | -------------------------------------------------------------------------------- /test/Test1/NoProject.fs: -------------------------------------------------------------------------------- 1 | module FileTwo 2 | 3 | open System.Collection 4 | -------------------------------------------------------------------------------- /test/Test1/Pervasive.fs: -------------------------------------------------------------------------------- 1 | let printtest args = 2 | printfn "Hello %d" 10 3 | 0 4 | -------------------------------------------------------------------------------- /test/Test1/Script.fsx: -------------------------------------------------------------------------------- 1 | 2 | 3 | module XA = 4 | let funky x = x + 1 5 | 6 | let val99 = XA.funky 21 7 | -------------------------------------------------------------------------------- /test/StructureTest/ContinuationLines.fs: -------------------------------------------------------------------------------- 1 | let x = 5 2 | let y = 3 | [ 1; 2 ] 4 | |> List.fold (fun x y -> x + y) 5 | 6 | let z = 5 + 7 | 6 8 | -------------------------------------------------------------------------------- /test/Test2/Main.fs: -------------------------------------------------------------------------------- 1 | module Test2.Main 2 | 3 | let val2 = List.map ((+) 1) [1;2] 4 | 5 | [] 6 | let main args = 7 | printfn "Hello %A" val2 8 | 0 9 | -------------------------------------------------------------------------------- /test/nuget.fsx: -------------------------------------------------------------------------------- 1 | #r "nuget: Newtonsoft.Json";; 2 | open Newtonsoft.Json;; 3 | 4 | let o = {| X = 2; Y = "Hello" |};; 5 | 6 | printfn "xxx:%s:xxx" (JsonConvert.SerializeObject o);; 7 | -------------------------------------------------------------------------------- /.dir-locals.el: -------------------------------------------------------------------------------- 1 | ;;; Directory Local Variables 2 | ;;; For more information see (info "(emacs) Directory Variables") 3 | 4 | ((emacs-lisp-mode . ((indent-tabs-mode . nil) 5 | (fill-column . 120)))) 6 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.elc 2 | bin 3 | tmp 4 | *~ 5 | 6 | # Useful for doing releases 7 | emacs-fsharp-mode-bin/ 8 | 9 | # Dependency archive 10 | fsautocomplete-*.zip 11 | 12 | # Development 13 | obj/ 14 | .ionide/ 15 | -------------------------------------------------------------------------------- /test/Test1/FileTwo.fs: -------------------------------------------------------------------------------- 1 | module FileTwo 2 | 3 | type Foo = 4 | | Bar 5 | | Qux 6 | 7 | let addition x y = x + y 8 | 9 | let add x y = x + y 10 | 11 | type NewObjectType() = 12 | 13 | member x.Terrific (y : int) : int = 14 | y 15 | -------------------------------------------------------------------------------- /test/StructureTest/Blocks.fs: -------------------------------------------------------------------------------- 1 | let notABlock = 5 2 | 3 | let basicBlock = 4 | [ 1; 2; 3 ] 5 | |> List.fold (fun x y -> x + y) 6 | 7 | type Shape = 8 | | Square 9 | | Rectangle 10 | | Triangle 11 | 12 | let aFunction x y = 13 | if x < y 14 | then 15 | x 16 | else 17 | y 18 | 19 | -------------------------------------------------------------------------------- /.github/pull_request_template.md: -------------------------------------------------------------------------------- 1 | ## Description 2 | 3 | 4 | 5 | ## How to test 6 | 7 | 8 | 9 | ## Related issues 10 | 11 | 12 | -------------------------------------------------------------------------------- /test/StructureTest/BracketIndent.fs: -------------------------------------------------------------------------------- 1 | let formatOne = [ "this" 2 | "that" 3 | "the-other" 4 | 5 | ] 6 | 7 | let formatTwo = [ 8 | "this" 9 | "that" 10 | 11 | ] 12 | 13 | let formatThree = 14 | [ "this" 15 | "that" 16 | "the-other" 17 | "hi" 18 | 19 | ] 20 | -------------------------------------------------------------------------------- /test/Test1/Program.fs: -------------------------------------------------------------------------------- 1 | module X = 2 | let func x = x + 1 3 | 4 | let testval = FileTwo.NewObjectType() 5 | 6 | let val2 = X.func 2 7 | 8 | let val3 = testval.Terrific val2 9 | 10 | let val4 : FileTwo.NewObjectType = testval 11 | 12 | type Dummy = Foo | Bar 13 | 14 | let val5:Dummy = Foo 15 | 16 | [] 17 | let main args = 18 | printfn "Hello %d" val2 19 | 0 20 | -------------------------------------------------------------------------------- /Eldev: -------------------------------------------------------------------------------- 1 | ; -*- mode: emacs-lisp; lexical-binding: t -*- 2 | 3 | (setq package-lint-main-file "eglot-fsharp.el") 4 | (setq eldev-project-main-file "eglot-fsharp.el") 5 | 6 | (eldev-use-package-archive 'melpa-unstable) 7 | (eldev-use-package-archive 'gnu) 8 | (eldev-use-plugin 'autoloads) 9 | (setq package-archive-priorities 10 | '(("melpa-unstable" . 400) 11 | ("gnu" . 300))) 12 | 13 | 14 | 15 | -------------------------------------------------------------------------------- /test/StructureTest/Relative.fs: -------------------------------------------------------------------------------- 1 | type Test = 2 | | Unit 3 | | Integration of string 4 | | EndToEnd 5 | 6 | 7 | if thing <> true then 8 | printfn "thing is not true" 9 | else if thing = true 10 | then 11 | printfn "maybe?" 12 | else 13 | printfn "it is so" 14 | 15 | 16 | let aThing (test : Test) = function 17 | | Unit -> () 18 | | Integration -> () 19 | | EndToEnd -> () 20 | -------------------------------------------------------------------------------- /test/Test1/Test1.fsproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Exe 5 | net9.0 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | -------------------------------------------------------------------------------- /test/apps/RecordHighlighting/Test.fsx: -------------------------------------------------------------------------------- 1 | type RecordTest1 = { something: int 2 | another: string } 3 | 4 | type RecordTest2 = { something :int; another :string } 5 | 6 | type RecordTest3 = { something : float; another: float; third :float; } 7 | 8 | type RecordTest4 = { 9 | something: int 10 | another: string } 11 | 12 | type RecordTest5 = 13 | { something: int 14 | another: string } 15 | 16 | type RecordTest6 = 17 | { 18 | something: int 19 | another: string 20 | third: Option 21 | } 22 | 23 | type RecordTest7 = 24 | { 25 | something: int 26 | another: string 27 | third: int option 28 | } 29 | -------------------------------------------------------------------------------- /ISSUE_TEMPLATE.md: -------------------------------------------------------------------------------- 1 | 2 | ### Description 3 | 4 | Please provide a succinct description of your issue. 5 | 6 | ### Repro steps 7 | 8 | Please provide the steps required to reproduce the problem 9 | 10 | 1. Step A 11 | 12 | 2. Step B 13 | 14 | ### Expected behavior 15 | 16 | Please provide a description of the behaviour you expect. 17 | 18 | ### Actual behavior 19 | 20 | Please provide a description of the actual behaviour you observe. 21 | 22 | ### Known workarounds 23 | 24 | Please provide a description of any known workarounds. 25 | 26 | ### Related information 27 | 28 | * Operating system 29 | * Branch 30 | * Emacs version 31 | * .NET Runtime, CoreCLR or Mono Version 32 | * Performance information, links to performance testing scripts 33 | -------------------------------------------------------------------------------- /test/apps/RecordHighlighting/Test.fsx.faceup: -------------------------------------------------------------------------------- 1 | «k:type» «t:RecordTest1» = { something: «t:int» 2 | another: «t:string» } 3 | 4 | «k:type» «t:RecordTest2» = { something :«t:int»; another :«t:string» } 5 | 6 | «k:type» «t:RecordTest3» = { something : «t:float»; another: «t:float»; third :«t:float»; } 7 | 8 | «k:type» «t:RecordTest4» = { 9 | something: «t:int» 10 | another: «t:string» } 11 | 12 | «k:type» «t:RecordTest5» = 13 | { something: «t:int» 14 | another: «t:string» } 15 | 16 | «k:type» «t:RecordTest6» = 17 | { 18 | something: «t:int» 19 | another: «t:string» 20 | third: «t:Option»«:fsharp-ui-generic-face:» 21 | } 22 | 23 | «k:type» «t:RecordTest7» = 24 | { 25 | something: «t:int» 26 | another: «t:string» 27 | third: «t:int option» 28 | } 29 | -------------------------------------------------------------------------------- /test/StructureTest/Nesting.fs: -------------------------------------------------------------------------------- 1 | // This file contains hand-crafted structures for use by `fsharp-mode-structure-tests.el`. 2 | // In particular, many/most of those tests need to work by: 3 | // 4 | // 1. Inserting text in a temp buffer 5 | // 2. Moving point to a known position 6 | // 3. Comparing computed values against expected answers 7 | // 8 | // Frequently, we're comparing things like, "what is the exact (point) position 9 | // of a given square brace." This means that formatting changes to this buffer 10 | // -- indeed, edits _of any kind_ -- will almost certainly break the tests! Edit 11 | // thoughtfully and intentionally! Update things as needed! 12 | 13 | // (point) of opening [: 640 14 | let aList = [ 1; 2; 3] 15 | 16 | // (point) of inner opening [: 706 17 | let nestedList = [ [ "this"; "that" ] ] 18 | 19 | // (point) of opening [: 777 20 | let multiLineList = [ 21 | "this" 22 | "that" 23 | ] 24 | 25 | // (point) of outermost opening [: 947 26 | // (point) of middle opening [: 953 27 | // (point) of innermost opening [: 955 28 | let multiLineNestedList = [ 29 | [ [ "how"; "now"] 30 | ] 31 | ] 32 | 33 | // (point) of opening {: 1060 34 | // (point) of inner {: 1121 35 | let anAsync = async { 36 | let value = funCall() 37 | 38 | let! differentValue = async { return! 5 } 39 | } 40 | 41 | // (point) of opening (: 1208 42 | let thing = 43 | [ 1; 2] 44 | |> List.map (fun i -> 45 | i ** i ) 46 | -------------------------------------------------------------------------------- /test/fsharp-mode-font-tests.el: -------------------------------------------------------------------------------- 1 | ;;; fsharp-mode-font-tests.el --- -*- lexical-binding: t; -*- 2 | 3 | (require 'buttercup) 4 | (require 'fsharp-mode) 5 | 6 | (defmacro with-highlighted (src &rest body) 7 | "Insert SRC in a temporary fsharp-mode buffer, apply syntax highlighting, 8 | then run BODY." 9 | `(with-temp-buffer 10 | (fsharp-mode) 11 | (insert ,src) 12 | (goto-char (point-min)) 13 | ;; Ensure we've syntax-highlighted the whole buffer. 14 | (if (fboundp 'font-lock-ensure) 15 | (font-lock-ensure) 16 | (with-no-warnings 17 | (font-lock-fontify-buffer))) 18 | ,@body)) 19 | 20 | (defun str-face (op) 21 | (goto-char (point-min)) 22 | (search-forward op) 23 | (left-char 2) 24 | (face-at-point)) 25 | 26 | (describe "When locking operators" 27 | (it "uses ui operator face for pipes" 28 | (with-highlighted "<<| |>> |> ||> |||> <| <|| <||| <|> <<|!" 29 | (should (equal (str-face " |> ") 'fsharp-ui-operator-face)) 30 | (should (equal (str-face " ||> ") 'fsharp-ui-operator-face)) 31 | (should (equal (str-face " |||> ") 'fsharp-ui-operator-face)) 32 | (should (equal (str-face " <| ") 'fsharp-ui-operator-face)) 33 | (should (equal (str-face " <|| ") 'fsharp-ui-operator-face)) 34 | (should (equal (str-face " <||| ") 'fsharp-ui-operator-face))))) 35 | 36 | (describe "When locking operators" 37 | (it "uses ui generic face for custom operators containing pipes" 38 | (with-highlighted "<<| |>> |> ||> |||> <| <|| <||| <|> <<|!" 39 | (should (equal (str-face "<<| ") 'fsharp-ui-generic-face)) 40 | (should (equal (str-face " |>> ") 'fsharp-ui-generic-face)) 41 | (should (equal (str-face " <|> ") 'fsharp-ui-generic-face)) 42 | (should (equal (str-face " <<|!") 'fsharp-ui-generic-face))))) 43 | -------------------------------------------------------------------------------- /.github/workflows/test.yml: -------------------------------------------------------------------------------- 1 | name: "CI" 2 | on: 3 | pull_request: 4 | push: 5 | branches: 6 | - master 7 | jobs: 8 | gnu-build: 9 | strategy: 10 | fail-fast: false 11 | matrix: 12 | os: [ubuntu-latest, macos-latest] 13 | dotnet: [9.0.x] 14 | emacs_version: 15 | - 28.2 16 | - 29.4 17 | - 30.2 18 | - snapshot 19 | runs-on: ${{ matrix.os }} 20 | steps: 21 | - uses: actions/checkout@v4 22 | - uses: actions/setup-dotnet@v4 23 | with: 24 | dotnet-version: ${{ matrix.dotnet }} 25 | - uses: purcell/setup-emacs@master 26 | with: 27 | version: ${{ matrix.emacs_version }} 28 | - name: Install Eldev 29 | run: curl -fsSL https://raw.github.com/doublep/eldev/master/webinstall/github-eldev | sh 30 | - name: Show dotnet sdks 31 | run: dotnet --list-sdks 32 | - name: Show dotnet version 33 | run: dotnet --info 34 | - name: Eldev archives 35 | run: | 36 | echo "Archives:" 37 | eldev archives 38 | - name: Eldev dependencies 39 | run: | 40 | echo "Dependencies:" 41 | eldev -v dependencies 42 | - name: Test 43 | run: | 44 | echo "Testing:" 45 | eldev -dtT test 46 | 47 | windows-build: 48 | runs-on: windows-latest 49 | strategy: 50 | fail-fast: false 51 | steps: 52 | - uses: actions/checkout@v4 53 | - uses: actions/setup-dotnet@v4 54 | with: 55 | dotnet-version: 9.0.x 56 | - name: Show dotnet sdks 57 | run: dotnet --list-sdks 58 | - name: Show dotnet version 59 | run: dotnet --info 60 | - name: Set up Emacs on Windows 61 | uses: jcs090218/setup-emacs-windows@master 62 | with: 63 | version: 29.4 64 | - name: Install Eldev 65 | run: curl.exe -fsSL https://raw.github.com/doublep/eldev/master/webinstall/eldev.bat | cmd /Q 66 | - name: Eldev archives 67 | run: | 68 | echo "Archives:" 69 | ~/.local/bin/eldev.bat archives 70 | - name: Eldev dependencies 71 | run: | 72 | echo "Dependencies:" 73 | ~/.local/bin/eldev.bat dependencies 74 | - name: Test 75 | run: | 76 | echo "Testing:" 77 | ~/.local/bin/eldev.bat -p -dtT test 78 | -------------------------------------------------------------------------------- /test/fsi-tests.el: -------------------------------------------------------------------------------- 1 | ;;; fsi-tests.el --- Tests for F# interactive -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2022-2023 Jürgen Hötzel 4 | 5 | ;; Author: Jürgen Hötzel 6 | ;; Keywords: processes 7 | 8 | ;; This program is free software; you can redistribute it and/or modify 9 | ;; it under the terms of the GNU General Public License as published by 10 | ;; the Free Software Foundation, either version 3 of the License, or 11 | ;; (at your option) any later version. 12 | 13 | ;; This program is distributed in the hope that it will be useful, 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ;; GNU General Public License for more details. 17 | 18 | ;; You should have received a copy of the GNU General Public License 19 | ;; along with this program. If not, see . 20 | 21 | ;;; Commentary: 22 | 23 | ;; 24 | 25 | ;;; Code: 26 | 27 | (load "project") ;Emacs 27 workaround: https://github.com/joaotavora/eglot/issues/549 28 | (require 'buttercup) 29 | (require 'fsharp-mode) 30 | 31 | (defun fsi-tests-wait-for-regex (timeout regexp) 32 | (let ((start-time (float-time))) 33 | (while (and (< (- (float-time) start-time) timeout) 34 | (not (progn (goto-char (point-min)) (search-forward-regexp regexp nil t)))) 35 | (if (accept-process-output (get-buffer-process (current-buffer)) 0.2) 36 | (message "[FSI Interactive] received output...") 37 | (message "[FSI Interactive] waiting for output..."))))) 38 | 39 | 40 | (describe "F# interactive" 41 | :before-all (run-fsharp inferior-fsharp-program) 42 | :before-each (with-current-buffer (get-buffer inferior-fsharp-buffer-name) 43 | (comint-clear-buffer)) 44 | (it "can eval expressions" 45 | (with-current-buffer (find-file-noselect "test/expression.fsx") 46 | (fsharp-eval-region (point-min) (point-max)) 47 | (with-current-buffer (get-buffer inferior-fsharp-buffer-name) 48 | (fsi-tests-wait-for-regex 25 "it: int = 2$") 49 | (let ((result (match-string-no-properties 0))) 50 | (expect result :to-equal "it: int = 2"))))) 51 | (it "can load nuget references" 52 | (let ((timeout 50) 53 | (fsx-file "test/nuget.fsx")) 54 | (with-current-buffer (find-file-noselect fsx-file) 55 | (fsharp-load-buffer-file) 56 | (with-current-buffer (get-buffer inferior-fsharp-buffer-name) 57 | (fsi-tests-wait-for-regex 25 "xxx:\\(.*\\):xxx") 58 | (let ((json-str (match-string-no-properties 1))) 59 | (unless json-str 60 | (warn "FSI output doesn't contain marker: %s" (buffer-substring-no-properties (point-min) (point-max)))) 61 | (expect json-str :to-equal "{\"X\":2,\"Y\":\"Hello\"}"))))))) 62 | 63 | (provide 'fsi-tests) 64 | ;;; fsi-tests.el ends here 65 | -------------------------------------------------------------------------------- /test/StructureTest/Literals.fs: -------------------------------------------------------------------------------- 1 | // Generated using https://hipsum.co/ 2 | 3 | // I'm a longer comment! Now, with Hipster Lorem Ipsum: 4 | // 5 | // Lorem ipsum dolor amet man braid +1 palo santo, whatever retro taxidermy 6 | // quinoa cred venmo church-key. Pok pok cray cornhole selvage irony keytar 7 | // disrupt man braid, everyday carry intelligentsia pitchfork street art hell 8 | // of. Schlitz air plant beard, fam authentic health goth hella fashion axe palo 9 | // santo pok pok. Hell of post-ironic artisan put a bird on it shoreditch shabby 10 | // chic. Bitters 3 wolf moon food truck adaptogen. 11 | // 12 | // Paleo fanny pack poutine, williamsburg health goth four dollar toast 13 | // aesthetic. Tbh viral truffaut live-edge asymmetrical ramps chillwave ethical 14 | // keytar fixie post-ironic vaporware air plant intelligentsia. Wayfarers 15 | // flannel iceland, DIY meditation celiac green juice disrupt. Food truck paleo 16 | // bicycle rights cold-pressed roof party normcore tumblr. 17 | 18 | let thisIsHereToBreakUpTheComments = 5 19 | 20 | (* This is the same thing, but in a different comment syntax. *) 21 | 22 | (* Lorem ipsum dolor amet man braid +1 palo santo, whatever retro taxidermy 23 | quinoa cred venmo church-key. Pok pok cray cornhole selvage irony keytar disrupt 24 | man braid, everyday carry intelligentsia pitchfork street art hell of. Schlitz 25 | air plant beard, fam authentic health goth hella fashion axe palo santo pok pok. 26 | Hell of post-ironic artisan put a bird on it shoreditch shabby chic. Bitters 3 27 | wolf moon food truck adaptogen. 28 | 29 | Paleo fanny pack poutine, williamsburg health goth four dollar toast aesthetic. 30 | Tbh viral truffaut live-edge asymmetrical ramps chillwave ethical keytar fixie 31 | post-ironic vaporware air plant intelligentsia. Wayfarers flannel iceland, DIY 32 | meditation celiac green juice disrupt. Food truck paleo bicycle rights 33 | cold-pressed roof party normcore tumblr. *) 34 | 35 | /// Yet again the same thing, but in a doc comment. 36 | /// 37 | /// Lorem ipsum dolor amet man braid +1 palo santo, whatever retro taxidermy 38 | /// quinoa cred venmo church-key. Pok pok cray cornhole selvage irony keytar 39 | /// disrupt man braid, everyday carry intelligentsia pitchfork street art hell 40 | /// of. Schlitz air plant beard, fam authentic health goth hella fashion axe 41 | /// palo santo pok pok. Hell of post-ironic artisan put a bird on it shoreditch 42 | /// shabby chic. Bitters 3 wolf moon food truck adaptogen. 43 | /// 44 | /// Paleo fanny pack poutine, williamsburg health goth four dollar toast 45 | /// aesthetic. Tbh viral truffaut live-edge asymmetrical ramps chillwave ethical 46 | /// keytar fixie post-ironic vaporware air plant intelligentsia. Wayfarers 47 | /// flannel iceland, DIY meditation celiac green juice disrupt. Food truck paleo 48 | /// bicycle rights cold-pressed roof party normcore tumblr. 49 | 50 | 51 | let simple = "this is a very normal string" 52 | 53 | let stringInString = "This contains another \"string\", so to speak." 54 | 55 | let longer = 56 | """ 57 | This is a triple-quoted string 58 | """ 59 | 60 | let evenLonger = """ 61 | This string is very long and had "normal extra quotes" and also 62 | a small number of \"escaped quotes\", and also a gratuitous it's. 63 | """ 64 | -------------------------------------------------------------------------------- /fsharp-mode-util.el: -------------------------------------------------------------------------------- 1 | ;;; fsharp-mode-util.el --- utility functions -*- lexical-binding: t -*- 2 | 3 | ;; Copyright (C) 2015 Robin Neatherway 4 | 5 | ;; Author: 2015 Robin Neatherway 6 | ;; Maintainer: Robin Neatherway 7 | ;; Keywords: languages 8 | 9 | ;; This file is not part of GNU Emacs. 10 | 11 | ;; This file is free software; you can redistribute it and/or modify 12 | ;; it under the terms of the GNU General Public License as published by 13 | ;; the Free Software Foundation; either version 3, or (at your option) 14 | ;; any later version. 15 | 16 | ;; This file is distributed in the hope that it will be useful, 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 | ;; GNU General Public License for more details. 20 | 21 | ;; You should have received a copy of the GNU General Public License 22 | ;; along with GNU Emacs; see the file COPYING. If not, write to 23 | ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 24 | ;; Boston, MA 02110-1301, USA. 25 | 26 | (require 'cl-lib) 27 | 28 | (defvar fsharp-ac-using-mono 29 | (cl-case system-type 30 | ((windows-nt cygwin msdos) nil) 31 | (otherwise t)) 32 | "Whether the .NET runtime in use is mono. 33 | Defaults to nil for Microsoft platforms (including Cygwin), t 34 | for all *nix.") 35 | 36 | (defun fsharp-mode--program-files-x86 () 37 | (file-name-as-directory 38 | (or (getenv "ProgramFiles(x86)") 39 | (getenv "ProgramFiles") 40 | "C:\\Program Files (x86)"))) 41 | 42 | (defun fsharp-mode--vs2017-msbuild-find (exe) 43 | "Return EXE absolute path for Visual Studio 2017, if existent, else nil." 44 | (let ((candidates (mapcar (lambda (edition) 45 | (concat (fsharp-mode--program-files-x86) 46 | edition 47 | "msbuild/15.0/bin/" 48 | exe)) 49 | '("Enterprise/" "Professional/" 50 | "Community/" "BuildTools/")))) 51 | (cl-find-if (lambda (exe) (file-executable-p exe)) candidates))) 52 | 53 | (defun fsharp-mode--msbuild-find (exe) 54 | (if fsharp-ac-using-mono 55 | (executable-find exe) 56 | (let* ((searchdirs (mapcar (lambda (ver) 57 | (concat (fsharp-mode--program-files-x86) 58 | "MSBuild/" ver "/Bin")) 59 | '("14.0" "13.0" "12.0"))) 60 | (exec-path (append searchdirs exec-path))) 61 | (or (fsharp-mode--vs2017-msbuild-find exe) (executable-find exe))))) 62 | 63 | (defun fsharp-mode--executable-find (exe) 64 | (if fsharp-ac-using-mono 65 | (executable-find exe) 66 | (let* ((searchdirs (mapcar (lambda (ver) 67 | (concat (fsharp-mode--program-files-x86) 68 | "Microsoft SDKs/F#/" 69 | ver "/Framework/v4.0")) 70 | '("10.1" "4.0" "3.1" "3.0"))) 71 | (exec-path (append searchdirs exec-path))) 72 | (executable-find exe)))) 73 | 74 | (provide 'fsharp-mode-util) 75 | 76 | ;;; fsharp-mode-util.el ends here 77 | -------------------------------------------------------------------------------- /test/Test2/Test2.fsproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Debug 5 | x86 6 | 8.0.30703 7 | 2.0 8 | {116cc2f9-f987-4b3d-915a-34cac04a73db} 9 | Library 10 | Test2 11 | Test2 12 | Test2 13 | False 14 | 15 | 16 | Program.fs 17 | 18 | 19 | 4.3.0.0 20 | 11 21 | 22 | 23 | True 24 | full 25 | False 26 | False 27 | bin\Debug\ 28 | DEBUG;TRACE 29 | 3 30 | x86 31 | bin\Debug\Test2.XML 32 | 33 | 34 | pdbonly 35 | True 36 | True 37 | bin\Release\ 38 | TRACE 39 | 3 40 | x86 41 | bin\Release\Test2.XML 42 | False 43 | 44 | 45 | 46 | True 47 | 48 | 49 | 50 | 51 | 52 | {116cc2f9-f987-4b3d-915a-34cac04a73da} 53 | Test1 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | $(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets 63 | 64 | 65 | 66 | 67 | $(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets 68 | 69 | 70 | 71 | 72 | 79 | 80 | -------------------------------------------------------------------------------- /test/integration-tests.el: -------------------------------------------------------------------------------- 1 | ;;; integration-tests.el --- -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2019-2023 Jürgen Hötzel 4 | 5 | ;; Author: Jürgen Hötzel 6 | ;; Keywords: abbrev, abbrev 7 | 8 | ;; This program is free software; you can redistribute it and/or modify 9 | ;; it under the terms of the GNU General Public License as published by 10 | ;; the Free Software Foundation, either version 3 of the License, or 11 | ;; (at your option) any later version. 12 | 13 | ;; This program is distributed in the hope that it will be useful, 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ;; GNU General Public License for more details. 17 | 18 | ;; You should have received a copy of the GNU General Public License 19 | ;; along with this program. If not, see . 20 | 21 | ;;; Commentary: 22 | 23 | ;; This file is part of fsharp-mode 24 | 25 | ;;; Code: 26 | 27 | (load "project") ;Emacs 27 workaround: https://github.com/joaotavora/eglot/issues/549 28 | (require 'buttercup) 29 | (require 'eglot-fsharp) 30 | (load "test/eglot-fsharp-integration-util.el") 31 | 32 | ;; FIXME/HELP WANTED: fsautocomplete process don't seem to terminate on windows (Access denied when trying to install 33 | ;; different version) 34 | (unless (eq system-type 'windows-nt) 35 | (describe "F# LSP Installation" 36 | :before-all (setq latest-version (eglot-fsharp--latest-version)) 37 | (it "succeeds using version 0.77.2" 38 | (eglot-fsharp--maybe-install "0.77.2") 39 | (expect (eglot-fsharp--installed-version) :to-equal "0.77.2")) 40 | (it (format "succeeds using latest version: %s)" latest-version) 41 | (eglot-fsharp--maybe-install) 42 | (expect (eglot-fsharp--installed-version) :to-equal latest-version)))) 43 | 44 | (describe "F# LSP Client" 45 | :before-all (progn (setq latest-version (eglot-fsharp--latest-version)) 46 | (with-temp-buffer (unless (zerop (process-file "dotnet" nil (current-buffer) nil "restore" "test/Test1")) 47 | (signal 'file-error (buffer-string)))) 48 | (eglot-fsharp--maybe-install) 49 | (with-current-buffer (eglot-fsharp--find-file-noselect "test/Test1/FileTwo.fs") 50 | (eglot-fsharp--tests-connect 10) 51 | (eglot-fsharp--sniff-method "fsharp/notifyWorkspace"))) 52 | 53 | (it "Can be invoked" 54 | ;; FIXME: Should use dotnet tool run 55 | (expect (process-file (eglot-fsharp--path-to-server) nil nil nil "--version") 56 | :to-equal 0)) 57 | (it "is enabled on F# Files" 58 | (with-current-buffer (eglot-fsharp--find-file-noselect "test/Test1/FileTwo.fs") 59 | (expect (type-of (eglot--current-server-or-lose)) :to-be 'eglot-fsautocomplete))) 60 | (it "shows flymake errors" 61 | (with-current-buffer (eglot-fsharp--find-file-noselect "test/Test1/Error.fs") 62 | (flymake-mode t) 63 | (flymake-start) 64 | (eglot-fsharp--sniff-diagnostics "test/Test1/Error.fs") 65 | (goto-char (point-min)) 66 | (search-forward "nonexisting") 67 | (insert "x") 68 | (eglot--signal-textDocument/didChange) 69 | (flymake-goto-next-error 1 '() t) 70 | (expect (face-at-point) :to-be 'flymake-error ))) 71 | (it "provides completion" 72 | (with-current-buffer (eglot-fsharp--find-file-noselect "test/Test1/FileTwo.fs") 73 | (expect (plist-get (eglot--capabilities (eglot--current-server-or-lose)) :completionProvider) :not :to-be nil))) 74 | (it "completes function in other modules" 75 | (with-current-buffer (eglot-fsharp--find-file-noselect "test/Test1/Program.fs") 76 | (search-forward "X.func") 77 | (delete-char -3) 78 | (completion-at-point) 79 | (expect (looking-back "X\\.func") :to-be t))) 80 | (it "finds definition in pervasives" 81 | (with-current-buffer (eglot-fsharp--find-file-noselect "test/Test1/Program.fs") 82 | (search-forward "printfn") 83 | (expect (current-word) :to-equal "printfn") ;sanity check 84 | (call-interactively #'xref-find-definitions) 85 | (expect (file-name-nondirectory (buffer-file-name)) :to-equal "fslib-extra-pervasives.fs"))) 86 | (it "finds definitions in other files of Project" 87 | (with-current-buffer (eglot-fsharp--find-file-noselect "test/Test1/Program.fs") 88 | (goto-char 150) 89 | (expect (current-word) :to-equal "NewObjectType") ;sanity check 90 | (call-interactively #'xref-find-definitions) 91 | (expect (file-name-nondirectory (buffer-file-name)) :to-equal "FileTwo.fs")))) 92 | 93 | 94 | (provide 'integration-tests) 95 | ;;; integration-tests.el ends here 96 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | [[http://melpa.org/#/fsharp-mode][file:http://melpa.org/packages/fsharp-mode-badge.svg]] 2 | [[https://stable.melpa.org/#/fsharp-mode][file:https://stable.melpa.org/packages/fsharp-mode-badge.svg]] 3 | [[https://github.com/fsharp/emacs-fsharp-mode/actions][file:https://github.com/fsharp/emacs-fsharp-mode/workflows/CI/badge.svg]] 4 | * fsharp-mode 5 | 6 | Provides support for the F# language in Emacs. Includes the following features: 7 | 8 | - Syntax highlighting and indentation 9 | - Support for F# Interactive 10 | - Via [[https://github.com/joaotavora/eglot/issues][Eglot]] LSP-client integration: 11 | - Displays type signatures and tooltips 12 | - Flymake 13 | - Completion 14 | - Jump to definition [[https://www.gnu.org/software/emacs/manual/html_node/emacs/Xref.html][Find Identifier References]] (Xref) 15 | 16 | ** LSP mode 17 | 18 | The current version of =fsharp-mode= installs =fsautocomplete.exe= 19 | automatically via =eglot-fsharp.el= (part of this mono repo, [[https://melpa.org/#/eglot-fsharp][eglot-fsharp 20 | on melpa]]) or [[https://github.com/emacs-lsp/lsp-mode][lsp-mode]] (untested). 21 | 22 | =fsharp-mode= is tested with Emacs 27.1+ and NET Core 6 (LTS) 23 | 24 | ** Installation 25 | 26 | *** Package 27 | 28 | =fsharp-mode= is available on [[https://melpa.org][MELPA]] and can 29 | be installed using the built-in package manager. 30 | 31 | If you're not already using MELPA, add the following to your init.el: 32 | 33 | #+BEGIN_SRC elisp 34 | ;;; Initialize MELPA 35 | (require 'package) 36 | (add-to-list 'package-archives '("melpa" . "http://melpa.org/packages/")) 37 | (unless package-archive-contents (package-refresh-contents)) 38 | (package-initialize) 39 | 40 | ;;; Install fsharp-mode 41 | (unless (package-installed-p 'fsharp-mode) 42 | (package-install 'fsharp-mode)) 43 | 44 | (require 'fsharp-mode) 45 | #+END_SRC 46 | 47 | If you are a user of [[https://github.com/jwiegley/use-package][use-package]] you can instead do 48 | 49 | #+BEGIN_SRC elisp 50 | (use-package fsharp-mode 51 | :defer t 52 | :ensure t) 53 | #+END_SRC 54 | 55 | *** From source 56 | 57 | I recommend to use [[https://cask.github.io/why-cask.html][Cask]]. Add this to your =Cask= file: 58 | 59 | #+BEGIN_SRC elisp 60 | (depends-on "fsharp-mode" :git "https://github.com/fsharp/emacs-fsharp-mode.git") 61 | #+END_SRC 62 | 63 | ** Eglot integration 64 | 65 | The =eglot-fsharp= integration is not part of [[https://melpa.org/#/fsharp-mode][fsharp-mode on melpa]]. 66 | 67 | It is available via the seperate package [[https://melpa.org/#/eglot-fsharp][eglot-fsharp on melpa]]. 68 | 69 | Add to your config: 70 | #+BEGIN_SRC elisp 71 | (require 'eglot-fsharp) 72 | #+END_SRC 73 | 74 | and execute =M-x eglot= 75 | 76 | With eglot running use `xref-find-definitions` (bound to =M-.= pr. default) to go to definition. Completions are accessable via. `completion-at-point` (or a completion backend ex. company-mode [[https://melpa.org/#/company]]) 77 | 78 | 79 | ** Projects 80 | 81 | =fsharp-mode= has support for Emacs build-in project management via =project.el= 82 | 83 | ** Configuration 84 | 85 | *** Compiler and REPL paths 86 | 87 | The F# compiler and interpreter should be set to good defaults for 88 | your OS as long as the relevant executables can be found on your PATH 89 | or in other standard locations. If you have a non-standard setup you 90 | may need to configure these paths manually. 91 | 92 | On Windows: 93 | 94 | #+BEGIN_SRC elisp 95 | (setq inferior-fsharp-program "c:\\Path\\To\\Fsi.exe") 96 | #+END_SRC 97 | 98 | On Unix-like systems, you must use the *--readline-* flag to ensure F# 99 | Interactive will work correctly with Emacs. Typically =fsi= and =fsc= are 100 | invoked through the shell scripts =fsharpi= and =fsharpc=: 101 | 102 | #+BEGIN_SRC elisp 103 | (setq inferior-fsharp-program "path/to/fsharpi --readline-") 104 | #+END_SRC 105 | 106 | *** Key Bindings 107 | 108 | If you are new to Emacs, you might want to use the menu (call 109 | =menu-bar-mode= if you don't see it). However, it's usually faster to learn 110 | a few useful bindings: 111 | 112 | | Key binding | Description | 113 | |------------------+-------------------------------------------| 114 | | =C-c C-r= | Evaluate region | 115 | | =C-c C-f= | Load current buffer into toplevel | 116 | | =C-c C-e= | Evaluate current toplevel phrase | 117 | | =C-M-x= | Evaluate current toplevel phrase | 118 | | =C-M-h= | Mark current toplevel phrase | 119 | | =C-c C-s= | Show interactive buffer | 120 | | =C-c C-c= | Compile with fsc | 121 | | =C-c x= | Run the executable | 122 | | =C-c C-a= | Open alternate file (.fsi or .fs) | 123 | | =C-c l= | Shift region to left | 124 | | =C-c r= | Shift region to right | 125 | | =C-c = | Move cursor to the beginning of the block | 126 | | =C-c C-d=, =M-.= | Jump to definition of symbol at point | 127 | | =C-c C-b=, =M-,= | Return to where point was before jump. | 128 | 129 | 130 | To interrupt the interactive mode, use =C-c C-c=. This is useful if your 131 | code does an infinite loop or a very long computation. 132 | 133 | If you want to shift the region by 2 spaces, use: =M-2 C-c r= 134 | 135 | In the interactive buffer, use ==M-RET= to send the code without 136 | explicitly adding the =;;= thing. 137 | 138 | 139 | ** Editor 140 | 141 | In order to change tab size it is possible to put this in emacs profile: 142 | 143 | #+BEGIN_SRC elisp 144 | (setq-default fsharp-indent-offset 2) 145 | #+END_SRC 146 | 147 | Because the F# language is sensitive to indentation, you might wan't to highlight indentation: 148 | 149 | #+BEGIN_SRC elisp 150 | (add-hook 'fsharp-mode-hook 'highlight-indentation-mode) 151 | #+END_SRC 152 | 153 | ** Troubleshooting 154 | 155 | =fsharp-mode= is still under development, so you may encounter some 156 | issues. Please report them so we can improve things! Open an issue on [[https://github.com/fsharp/emacs-fsharp-mode/][Github]]. 157 | 158 | *** No autocompletion in FSX files 159 | 160 | The root cause is documented in this Ionide issue: [[https://github.com/ionide/ionide-vscode-fsharp/issues/1244][4.2.0 - No auto complete or typechecking in FSX files]] 161 | 162 | As a workaround can add a reference to the facade netstandard assembly (path is platform/SDK-dependent). 163 | 164 | On Arch Linux using [[https://aur.archlinux.org/packages/dotnet-sdk-lts-bin][dotnet sdk lts]] add this to your =fsx= file: 165 | #+BEGIN_SRC fsharp 166 | #r "/opt/dotnet/sdk/2.1.801/ref/netstandard.dll" 167 | #+END_SRC 168 | 169 | *** Project file issues 170 | 171 | If your project file does not seem to be being parsed correctly, so 172 | that you have missing references or other incorrect intellisense 173 | results, it is possible to obtain a detailed log of LSP events in this buffers: 174 | 175 | 176 | - =*EGLOT (PROJECT/fsharp-mode) stderr*= 177 | - =*EGLOT (PROJECT/fsharp-mode) output*= 178 | - =*EGLOT (PROJECT/fsharp-mode) events*= 179 | 180 | ** Contributing 181 | 182 | This project is maintained by the 183 | [[http://fsharp.org/][F# Software Foundation]], with the repository hosted 184 | on [[https://github.com/fsharp/emacs-fsharp-mode][GitHub]]. 185 | 186 | Pull requests are welcome. Please run the test-suite with [[https://doublep.github.io/eldev/][Eldev]] =eldev -dtT test= 187 | before submitting a pull request. 188 | 189 | *** Maintainers 190 | 191 | The maintainers of this repository appointed by the F# Core Engineering Group are: 192 | 193 | - [[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]] 194 | - The primary maintainer for this repository is [[https://github.com/juergenhoetzel][Jürgen Hötzel]] 195 | 196 | Previous maintainers: 197 | - [[https://github.com/rneatherway][Robin Neatherway]] 198 | 199 | 200 | 201 | 202 | -------------------------------------------------------------------------------- /test/eglot-fsharp-integration-util.el: -------------------------------------------------------------------------------- 1 | ;;; eglot-fsharp-integration-util.el --- Helper for eglot integration tests -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2022-2023 Jürgen Hötzel 4 | 5 | ;; Author: Jürgen Hötzel 6 | ;; Keywords: processes 7 | 8 | ;; This program is free software; you can redistribute it and/or modify 9 | ;; it under the terms of the GNU General Public License as published by 10 | ;; the Free Software Foundation, either version 3 of the License, or 11 | ;; (at your option) any later version. 12 | 13 | ;; This program is distributed in the hope that it will be useful, 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ;; GNU General Public License for more details. 17 | 18 | ;; You should have received a copy of the GNU General Public License 19 | ;; along with this program. If not, see . 20 | 21 | ;;; Commentary: 22 | 23 | ;; 24 | 25 | ;;; Code: 26 | (require 'edebug) 27 | 28 | (cl-defmacro eglot-fsharp--with-timeout (timeout &body body) 29 | (declare (indent 1) (debug t)) 30 | `(eglot-fsharp--call-with-timeout ,timeout (lambda () ,@body))) 31 | 32 | (defun eglot-fsharp--call-with-timeout (timeout fn) 33 | (let* ((tag (gensym "eglot-test-timeout")) 34 | (timed-out (make-symbol "timeout")) 35 | (timeout-and-message 36 | (if (listp timeout) timeout 37 | (list timeout "waiting for test to finish"))) 38 | (timeout (car timeout-and-message)) 39 | (message (cadr timeout-and-message)) 40 | (timer) 41 | (retval)) 42 | (unwind-protect 43 | (setq retval 44 | (catch tag 45 | (setq timer 46 | (run-with-timer timeout nil 47 | (lambda () 48 | (unless edebug-active 49 | (throw tag timed-out))))) 50 | (funcall fn))) 51 | (cancel-timer timer) 52 | (when (eq retval timed-out) 53 | (warn "Received Events for %s : %s" 54 | (file-name-nondirectory (buffer-file-name)) 55 | (with-current-buffer (jsonrpc-events-buffer (eglot-current-server)) (buffer-string))) 56 | (error "%s" (concat "Timed out " message)))))) 57 | 58 | 59 | (defun eglot-fsharp--find-file-noselect (file &optional noerror) 60 | (unless (or noerror 61 | (file-readable-p file)) (error "%s does not exist" file)) 62 | (find-file-noselect file)) 63 | 64 | (defun eglot-fsharp--tests-connect (&optional timeout) 65 | (let* ((timeout (or timeout 10)) 66 | (eglot-sync-connect t) 67 | (eglot-connect-timeout timeout)) 68 | (apply #'eglot--connect (eglot--guess-contact)))) 69 | 70 | (cl-defmacro eglot-fsharp--wait-for ((events-sym &optional (timeout 1) message) args &body body) 71 | "Spin until FN match in EVENTS-SYM, flush events after it. 72 | Pass TIMEOUT to `eglot--with-timeout'." 73 | (declare (indent 2) (debug (sexp sexp sexp &rest form))) 74 | `(eglot-fsharp--with-timeout '(,timeout ,(or message 75 | (format "waiting for:\n%s" (pp-to-string body)))) 76 | (let ((event 77 | (cl-loop thereis (cl-loop for json in ,events-sym 78 | for method = (plist-get json :method) 79 | when (keywordp method) 80 | do (plist-put json :method 81 | (substring 82 | (symbol-name method) 83 | 1)) 84 | when (funcall 85 | (jsonrpc-lambda ,args ,@body) json) 86 | return (cons json before) 87 | collect json into before) 88 | for i from 0 89 | when (zerop (mod i 5)) 90 | ;; do (eglot--message "still struggling to find in %s" 91 | ;; ,events-sym) 92 | do 93 | ;; `read-event' is essential to have the file 94 | ;; watchers come through. 95 | (read-event "[eglot] Waiting a bit..." nil 0.1) 96 | (accept-process-output nil 0.1)))) 97 | (setq ,events-sym (cdr event)) 98 | (eglot--message "Event detected:\n%s" 99 | (pp-to-string (car event)))))) 100 | 101 | 102 | (cl-defmacro eglot-fsharp--sniffing ((&key server-requests 103 | server-notifications 104 | server-replies 105 | client-requests 106 | client-notifications 107 | client-replies) 108 | &rest body) 109 | "Run BODY saving LSP JSON messages in variables, most recent first." 110 | (declare (indent 1) (debug (sexp &rest form))) 111 | (let ((log-event-ad-sym (make-symbol "eglot-fsharp--event-sniff"))) 112 | `(unwind-protect 113 | (let ,(delq nil (list server-requests 114 | server-notifications 115 | server-replies 116 | client-requests 117 | client-notifications 118 | client-replies)) 119 | (advice-add 120 | #'jsonrpc--log-event :before 121 | (lambda (_proc message &optional type) 122 | (cl-destructuring-bind (&key method id _error &allow-other-keys) 123 | message 124 | (let ((req-p (and method id)) 125 | (notif-p method) 126 | (reply-p id)) 127 | (cond 128 | ((eq type 'server) 129 | (cond (req-p ,(when server-requests 130 | `(push message ,server-requests))) 131 | (notif-p ,(when server-notifications 132 | `(push message ,server-notifications))) 133 | (reply-p ,(when server-replies 134 | `(push message ,server-replies))))) 135 | ((eq type 'client) 136 | (cond (req-p ,(when client-requests 137 | `(push message ,client-requests))) 138 | (notif-p ,(when client-notifications 139 | `(push message ,client-notifications))) 140 | (reply-p ,(when client-replies 141 | `(push message ,client-replies))))))))) 142 | '((name . ,log-event-ad-sym))) 143 | ,@body) 144 | (advice-remove #'jsonrpc--log-event ',log-event-ad-sym)))) 145 | 146 | 147 | 148 | (defun eglot-fsharp--sniff-diagnostics (file-name-suffix) 149 | (eglot-fsharp--sniffing (:server-notifications s-notifs) 150 | (eglot-fsharp--wait-for (s-notifs 20) 151 | (&key _id method params &allow-other-keys) 152 | (and 153 | (string= method "textDocument/publishDiagnostics") 154 | (string-suffix-p file-name-suffix (plist-get params :uri)))))) 155 | 156 | (defun eglot-fsharp--sniff-method (method-name) 157 | (eglot-fsharp--sniffing (:server-notifications s-notifs) 158 | (eglot-fsharp--wait-for (s-notifs 20) 159 | (&key _id method params &allow-other-keys) 160 | (and 161 | (string= method method-name))))) 162 | 163 | (provide 'eglot-fsharp-integration-util) 164 | ;;; integration-util.el ends here 165 | -------------------------------------------------------------------------------- /inf-fsharp-mode.el: -------------------------------------------------------------------------------- 1 | ;;; inf-fsharp-mode.el --- Support for F# interactive 2 | 3 | ;; Copyright (C) 1997 INRIA 4 | 5 | ;; Author: 1993-1997 Xavier Leroy, Jacques Garrigue 6 | ;; 2010-2011 Laurent Le Brun 7 | ;; Maintainer: Robin Neatherway 8 | ;; Keywords: languages 9 | 10 | ;; This file is not part of GNU Emacs. 11 | 12 | ;; This file is free software; you can redistribute it and/or modify 13 | ;; it under the terms of the GNU General Public License as published by 14 | ;; the Free Software Foundation; either version 3, or (at your option) 15 | ;; any later version. 16 | 17 | ;; This file is distributed in the hope that it will be useful, 18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 20 | ;; GNU General Public License for more details. 21 | 22 | ;; You should have received a copy of the GNU General Public License 23 | ;; along with GNU Emacs; see the file COPYING. If not, write to 24 | ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 25 | ;; Boston, MA 02110-1301, USA. 26 | 27 | (require 'tramp) 28 | (require 'comint) 29 | (require 'fsharp-mode-util) 30 | 31 | (require 'cl-lib) 32 | 33 | ;; User modifiable variables 34 | 35 | ;; Whether you want the output buffer to be diplayed when you send a phrase 36 | 37 | (defvar fsharp-display-when-eval t 38 | "*If true, display the inferior fsharp buffer when evaluating expressions.") 39 | 40 | (defvar inferior-fsharp-program 41 | (cond 42 | ((executable-find "dotnet") "dotnet fsi --readline-") 43 | (fsharp-ac-using-mono "fsharpi --readline-") 44 | (t (concat "\"" (fsharp-mode--executable-find "fsi.exe") "\" --fsi-server-input-codepage:65001"))) 45 | "Inferior F# command.") 46 | 47 | ;; End of User modifiable variables 48 | 49 | 50 | (defvar inferior-fsharp-mode-map 51 | (let ((map (copy-keymap comint-mode-map))) 52 | (define-key map [M-return] 'fsharp-comint-send) 53 | map)) 54 | 55 | ;; Augment fsharp mode, so you can process fsharp code in the source files. 56 | 57 | (define-derived-mode inferior-fsharp-mode comint-mode "Inferior fsharp" 58 | "Major mode for interacting with an inferior fsharp process. 59 | Runs a fsharp toplevel as a subprocess of Emacs, with I/O through an 60 | Emacs buffer. A history of input phrases is maintained. Phrases can 61 | be sent from another buffer in fsharp mode. 62 | 63 | \\{inferior-fsharp-mode-map}" 64 | (setq comint-prompt-regexp "^> ?") 65 | (setq comint-prompt-read-only t) 66 | 67 | (set (make-local-variable 'paragraph-start) (concat "^$\\|" page-delimiter)) 68 | (set (make-local-variable 'paragraph-separate) paragraph-start) 69 | (set (make-local-variable 'paragraph-ignore-fill-prefix) t) 70 | (set (make-local-variable 'require-final-newline) t) 71 | (set (make-local-variable 'comment-start) "(*") 72 | (set (make-local-variable 'comment-end) "*)") 73 | (set (make-local-variable 'comment-column) 40) 74 | (set (make-local-variable 'comment-start-skip) "(\\*+ *") 75 | (set (make-local-variable 'parse-sexp-ignore-comments) nil) 76 | (set (make-local-variable 'comint-process-echoes) t) 77 | (run-hooks 'inferior-fsharp-mode-hooks) 78 | 79 | ;; use compilation mode to parse errors, but RET and C-cC-c should still be from comint-mode 80 | (compilation-minor-mode) 81 | (make-local-variable 'minor-mode-map-alist) 82 | (setq minor-mode-map-alist (assq-delete-all 'compilation-minor-mode (cl-copy-seq minor-mode-map-alist)))) 83 | 84 | (defconst inferior-fsharp-buffer-subname "inferior-fsharp") 85 | (defconst inferior-fsharp-buffer-name 86 | (concat "*" inferior-fsharp-buffer-subname "*")) 87 | 88 | (defun fsharp--localname (file) 89 | "Return localname of a Tramp filename. 90 | If FILE is not a Tramp filename return FILENAME" 91 | (if (tramp-tramp-file-p file) 92 | (with-parsed-tramp-file-name file nil 93 | localname) 94 | file)) 95 | 96 | (defun fsharp-run-process-if-needed (&optional cmd) 97 | "Launch fsi if needed, using CMD if supplied." 98 | (unless (comint-check-proc inferior-fsharp-buffer-name) 99 | (setq inferior-fsharp-program 100 | (or cmd (read-from-minibuffer "fsharp toplevel to run: " 101 | inferior-fsharp-program))) 102 | (let ((cmdlist (inferior-fsharp-args-to-list inferior-fsharp-program)) 103 | (process-connection-type 'pty)) 104 | (with-current-buffer (apply (function make-comint) 105 | inferior-fsharp-buffer-subname 106 | (car cmdlist) nil 107 | (cdr cmdlist)) 108 | (when (eq system-type 'windows-nt) 109 | (set-process-coding-system (get-buffer-process (current-buffer)) 110 | 'utf-8 'utf-8)) 111 | (inferior-fsharp-mode)) 112 | (display-buffer inferior-fsharp-buffer-name)))) 113 | 114 | ;;;###autoload 115 | (defun run-fsharp (&optional cmd) 116 | "Run an inferior fsharp process. 117 | Input and output via buffer `*inferior-fsharp*'." 118 | (interactive 119 | (list (if (not (comint-check-proc inferior-fsharp-buffer-name)) 120 | (read-from-minibuffer "fsharp toplevel to run: " 121 | inferior-fsharp-program)))) 122 | (fsharp-run-process-if-needed cmd) 123 | (switch-to-buffer-other-window inferior-fsharp-buffer-name)) 124 | 125 | ;; split the command line (e.g. "mono fsi" -> ("mono" "fsi")) 126 | ;; we double the \ before unquoting, so that the user doesn't have to 127 | (defun inferior-fsharp-args-to-list (string) 128 | (split-string-and-unquote (replace-regexp-in-string "\\\\" "\\\\\\\\" string))) 129 | 130 | (defun inferior-fsharp-show-subshell () 131 | (interactive) 132 | (fsharp-run-process-if-needed) 133 | (display-buffer inferior-fsharp-buffer-name) 134 | 135 | (let ((buf (current-buffer)) 136 | (fsharp-buf (get-buffer inferior-fsharp-buffer-name)) 137 | (count 0)) 138 | (while 139 | (and (< count 10) 140 | (not (equal (buffer-name (current-buffer)) 141 | inferior-fsharp-buffer-name))) 142 | (next-multiframe-window) 143 | (setq count (+ count 1))) 144 | (if (equal (buffer-name (current-buffer)) 145 | inferior-fsharp-buffer-name) 146 | (goto-char (point-max))) 147 | (while 148 | (> count 0) 149 | (previous-multiframe-window) 150 | (setq count (- count 1))))) 151 | 152 | (defun inferior-fsharp-eval-region (start end) 153 | "Send the current region to the inferior fsharp process." 154 | (interactive "r") 155 | (fsharp-run-process-if-needed) 156 | ;; send location to fsi 157 | (let* ((name (file-truename (buffer-file-name (current-buffer)))) 158 | (dir (fsharp--localname (file-name-directory name))) 159 | (line (number-to-string (line-number-at-pos start))) 160 | (loc (concat "# " line " \"" name "\"\n")) 161 | (movedir (concat "#silentCd @\"" dir "\";;\n"))) 162 | (comint-send-string inferior-fsharp-buffer-name movedir) 163 | (comint-send-string inferior-fsharp-buffer-name loc)) 164 | (save-excursion 165 | (goto-char end) 166 | (comint-send-region inferior-fsharp-buffer-name start (point)) 167 | ;; normally, ";;" are part of the region 168 | (if (and (>= (point) 2) 169 | (prog2 (backward-char 2) (looking-at ";;"))) 170 | (comint-send-string inferior-fsharp-buffer-name "\n") 171 | (comint-send-string inferior-fsharp-buffer-name "\n;;\n")) 172 | ;; the user may not want to see the output buffer 173 | (if fsharp-display-when-eval 174 | (display-buffer inferior-fsharp-buffer-name t)))) 175 | 176 | (defvar fsharp-previous-output nil 177 | "tells the beginning of output in the shell-output buffer, so that the 178 | output can be retreived later, asynchronously.") 179 | 180 | ;; To insert the last output from fsharp at point 181 | (defun fsharp-insert-last-output () 182 | "Insert the result of the evaluation of previous phrase" 183 | (interactive) 184 | (let ((pos (process-mark (get-buffer-process inferior-fsharp-buffer-name)))) 185 | (insert-buffer-substring inferior-fsharp-buffer-name 186 | fsharp-previous-output (- pos 2)))) 187 | 188 | 189 | (defun fsharp-simple-send (proc string) 190 | (comint-simple-send proc (concat string ";;"))) 191 | 192 | (defun fsharp-comint-send () 193 | (interactive) 194 | (let ((comint-input-sender 'fsharp-simple-send)) 195 | (comint-send-input))) 196 | 197 | (provide 'inf-fsharp-mode) 198 | 199 | ;;; inf-sharp-mode.el ends here 200 | -------------------------------------------------------------------------------- /test/apps/FQuake3/NativeMappings.fs: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright (C) 2013 William F. Smith 3 | 4 | This program is free software; you can redistribute it 5 | and/or modify it under the terms of the GNU General Public License as 6 | published by the Free Software Foundation; either version 2 of the License, 7 | or (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be 10 | useful, but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with this program; if not, write to the Free Software 16 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 17 | 18 | Derivative of Quake III Arena source: 19 | Copyright (C) 1999-2005 Id Software, Inc. 20 | *) 21 | 22 | // Disable native interop warnings 23 | #nowarn "9" 24 | #nowarn "51" 25 | 26 | namespace Engine.Native 27 | 28 | open System 29 | open System.IO 30 | open System.Runtime.InteropServices 31 | open Microsoft.FSharp.NativeInterop 32 | open FSharp.Game.Math 33 | open Engine.Core 34 | open Engine.Net 35 | open Engine.FileSystem 36 | open Engine.NativeInterop 37 | open FQuake3.Math 38 | open FQuake3.Md3 39 | 40 | /// Used to prevent massive copying of large immutable data. 41 | module private Cache = 42 | let mutable md3Map = Map.empty 43 | 44 | module Boolean = 45 | let inline ofNativePtr (ptr: nativeptr) = 46 | let mutable native = NativePtr.read ptr 47 | 48 | match native with 49 | | qboolean.qtrue -> true 50 | | _ -> false 51 | 52 | let inline toNativeByPtr (ptr: nativeptr) (value: bool) = 53 | let mutable native = NativePtr.read ptr 54 | 55 | native <- if value then qboolean.qtrue else qboolean.qfalse 56 | 57 | NativePtr.write ptr native 58 | 59 | let inline toNative (value: bool) = 60 | if value then qboolean.qtrue else qboolean.qfalse 61 | 62 | module Vec2 = 63 | let inline ofNativePtr (ptr: nativeptr) = 64 | let mutable native = NativePtr.read ptr 65 | 66 | vec2 (native.value, native.value1) 67 | 68 | let inline toNativeByPtr (ptr: nativeptr) (v: vec2) = 69 | let mutable native = NativePtr.read ptr 70 | 71 | native.value <- v.X 72 | native.value1 <- v.Y 73 | 74 | NativePtr.write ptr native 75 | 76 | module Vec3 = 77 | let inline ofNativePtr (ptr: nativeptr) = 78 | let mutable native = NativePtr.read ptr 79 | 80 | vec3 (native.value, native.value1, native.value2) 81 | 82 | let inline toNativeByPtr (ptr: nativeptr) (v: vec3) = 83 | let mutable native = NativePtr.read ptr 84 | 85 | native.value <- v.X 86 | native.value1 <- v.Y 87 | native.value2 <- v.Z 88 | 89 | NativePtr.write ptr native 90 | 91 | module Vec4 = 92 | let inline ofNativePtr (ptr: nativeptr) = 93 | let mutable native = NativePtr.read ptr 94 | 95 | vec4 (native.value, native.value1, native.value2, native.value3) 96 | 97 | let inline toNativeByPtr (ptr: nativeptr) (v: vec4) = 98 | let mutable native = NativePtr.read ptr 99 | 100 | native.value <- v.X 101 | native.value1 <- v.Y 102 | native.value2 <- v.Z 103 | native.value3 <- v.W 104 | 105 | NativePtr.write ptr native 106 | 107 | module Mat4 = 108 | let inline ofNativePtr (ptr: nativeptr) = 109 | mat4 ( 110 | (NativePtr.get ptr 0), 111 | (NativePtr.get ptr 1), 112 | (NativePtr.get ptr 2), 113 | (NativePtr.get ptr 3), 114 | (NativePtr.get ptr 4), 115 | (NativePtr.get ptr 5), 116 | (NativePtr.get ptr 6), 117 | (NativePtr.get ptr 7), 118 | (NativePtr.get ptr 8), 119 | (NativePtr.get ptr 9), 120 | (NativePtr.get ptr 10), 121 | (NativePtr.get ptr 11), 122 | (NativePtr.get ptr 12), 123 | (NativePtr.get ptr 13), 124 | (NativePtr.get ptr 14), 125 | (NativePtr.get ptr 15) 126 | ) 127 | 128 | let inline toNativeByPtr (ptr: nativeptr) (m: mat4) = 129 | NativePtr.set ptr 0 m.[0, 0] 130 | NativePtr.set ptr 1 m.[0, 1] 131 | NativePtr.set ptr 2 m.[0, 2] 132 | NativePtr.set ptr 3 m.[0, 3] 133 | NativePtr.set ptr 4 m.[1, 0] 134 | NativePtr.set ptr 5 m.[1, 1] 135 | NativePtr.set ptr 6 m.[1, 2] 136 | NativePtr.set ptr 7 m.[1, 3] 137 | NativePtr.set ptr 8 m.[2, 0] 138 | NativePtr.set ptr 9 m.[2, 1] 139 | NativePtr.set ptr 10 m.[2, 2] 140 | NativePtr.set ptr 11 m.[2, 3] 141 | NativePtr.set ptr 12 m.[3, 0] 142 | NativePtr.set ptr 13 m.[3, 1] 143 | NativePtr.set ptr 14 m.[3, 2] 144 | NativePtr.set ptr 15 m.[3, 3] 145 | 146 | module Cvar = 147 | let inline ofNativePtr (ptr: nativeptr) = 148 | let mutable native = NativePtr.read ptr 149 | 150 | { 151 | Name = NativePtr.toStringAnsi native.name; 152 | String = NativePtr.toStringAnsi native.string; 153 | ResetString = NativePtr.toStringAnsi native.resetString; 154 | LatchedString = NativePtr.toStringAnsi native.latchedString; 155 | Flags = native.flags; 156 | IsModified = Boolean.ofNativePtr &&native.modified; 157 | ModificationCount = native.modificationCount; 158 | Value = native.value; 159 | Integer = native.integer; 160 | } 161 | 162 | module Bounds = 163 | let inline ofNativePtr (ptr: nativeptr) = 164 | Bounds ( 165 | Vec3.ofNativePtr <| NativePtr.add ptr 0, 166 | Vec3.ofNativePtr <| NativePtr.add ptr 1) 167 | 168 | let inline toNativeByPtr (ptr: nativeptr) (bounds: Bounds) = 169 | let mutable nativeX = NativePtr.get ptr 0 170 | let mutable nativeY = NativePtr.get ptr 1 171 | 172 | Vec3.toNativeByPtr &&nativeX bounds.Min 173 | Vec3.toNativeByPtr &&nativeY bounds.Max 174 | 175 | NativePtr.set ptr 0 nativeX 176 | NativePtr.set ptr 1 nativeY 177 | 178 | module Message = 179 | let inline ofNativePtr (ptr: nativeptr) = 180 | let mutable native = NativePtr.read ptr 181 | 182 | { 183 | IsAllowedOverflow = Boolean.ofNativePtr &&native.allowoverflow; 184 | IsOverflowed = Boolean.ofNativePtr &&native.overflowed; 185 | IsOutOfBand = Boolean.ofNativePtr &&native.oob; 186 | Data = Seq.ofNativePtrArray native.cursize native.data; 187 | MaxSize = native.maxsize; 188 | ReadCount = native.readcount; 189 | Bit = native.bit; 190 | } 191 | 192 | module IPAddress = 193 | let inline ofNativePtr (ptr: nativeptr) = 194 | { 195 | Octet1 = NativePtr.get ptr 0; 196 | Octet2 = NativePtr.get ptr 1; 197 | Octet3 = NativePtr.get ptr 2; 198 | Octet4 = NativePtr.get ptr 3; 199 | } 200 | 201 | module Address = 202 | let inline ofNativePtr (ptr: nativeptr) = 203 | let mutable native = NativePtr.read ptr 204 | 205 | { 206 | Type = enum (int native.type'); 207 | IP = IPAddress.ofNativePtr &&native.ip 208 | Port = native.port; 209 | } 210 | 211 | module Md3Frame = 212 | let inline ofNativePtr (ptr: nativeptr) = 213 | let mutable native = NativePtr.read ptr 214 | 215 | { 216 | Bounds = Bounds.ofNativePtr &&native.bounds; 217 | LocalOrigin = Vec3.ofNativePtr &&native.localOrigin; 218 | Radius = native.radius; 219 | Name = NativePtr.toStringAnsi &&native.name; 220 | } 221 | 222 | module Md3 = 223 | let ofNativePtr (ptr: nativeptr) = 224 | let mutable native = NativePtr.read ptr 225 | 226 | let hash = NativePtr.toNativeInt ptr 227 | 228 | match Map.tryFind hash Cache.md3Map with 229 | | Some x -> x 230 | | None -> 231 | 232 | let bytes = Array.zeroCreate native.ofsEnd 233 | Marshal.Copy (NativePtr.toNativeInt ptr, bytes, 0, native.ofsEnd) 234 | let md3 = FQuake3.Utils.Md3.parse bytes 235 | Cache.md3Map <- Map.add hash md3 Cache.md3Map 236 | md3 237 | 238 | module DirectoryInfo = 239 | let ofNativePtr (ptr: nativeptr) = 240 | let mutable native = NativePtr.read ptr 241 | 242 | let path = NativePtr.toStringAnsi &&native.path 243 | let name = NativePtr.toStringAnsi &&native.gamedir 244 | 245 | DirectoryInfo (Path.Combine (path, name)) 246 | 247 | module Pak = 248 | let ofNativePtr (ptr: nativeptr) = 249 | let mutable native = NativePtr.read ptr 250 | 251 | { 252 | FileInfo = FileInfo (NativePtr.toStringAnsi &&native.pakFilename); 253 | Checksum = native.checksum; 254 | PureChecksum = native.checksum; 255 | FileCount = native.numfiles; 256 | } 257 | 258 | module ServerPakChecksum = 259 | let createFrom_fs_serverPaks (size: int) (ptr: nativeptr) = 260 | match NativePtr.isValid ptr with 261 | | false -> [] 262 | | _ -> NativePtr.toList size ptr 263 | 264 | module SearchPath = 265 | let ofNativePtr (ptr: nativeptr) = 266 | let mutable native = NativePtr.read ptr 267 | 268 | { 269 | DirectoryInfo = Option.ofNativePtr DirectoryInfo.ofNativePtr native.directory 270 | } 271 | 272 | let convertFrom_fs_searchpaths (ptr: nativeptr) = 273 | let rec f (searchPaths: SearchPath list) (ptr: nativeptr) = 274 | match NativePtr.isValid ptr with 275 | | false -> searchPaths 276 | | _ -> 277 | let mutable native = NativePtr.read ptr 278 | f (ofNativePtr ptr :: searchPaths) (native.next) 279 | 280 | f [] ptr 281 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## 1.10 (2019.12-01) 2 | 3 | Features: 4 | - #210: Remove old FsAutoComplete support (use LSP) 5 | - provide eglot (Emacs LSP client) integration and add eglot 6 | integration tests (using Emacs buttercup) 7 | - Use Cask instead to automate the package development cycle; 8 | development, dependencies, testing, building, packaging 9 | - Make project.el aware of F# projects 10 | - Use Emacs org-mode for README 11 | Bugfixes: 12 | - #68: Indentation Cleanup / SMIE mode not being applied properly 13 | (Gastove) 14 | 15 | ## 1.9.14 (2019-06-09) 16 | 17 | Features: 18 | - #207: Update to FsAutoComplete 0.38.1 19 | - #206: Set default build command to msbuild if found 20 | Bugfixes: 21 | - #198: Use buffer-local version of company-quickhelp-mode 22 | 23 | ## 1.9.13 (2018) 24 | 25 | Features: 26 | - #193: Update to FSAC 0.36 27 | - Fixes #183: Load .Net Core projects that reference other projects 28 | - Fixes #182: .fs files not parsed 29 | Bugfixes: 30 | - #190: Fix attribute locking, improve imenu support 31 | - #189: Fix bug in font locking for active patterns 32 | - #187: Fix Infinite loop when file begins with a comment preceded 33 | by whitespace 34 | - #180: Use scoop instead of Chocolatey package for Appveyor testing 35 | - #179: Use portable (Windows support) Makefile 36 | - #176: Add F# Tools 10.1 SDK directory to search dirs 37 | - #175: Paths with characters outside ASCII gives error FS2302 (Windows) 38 | - #171: Fix for phrase detection for if/then/else constructs 39 | 40 | ## 1.9.12 (2018-05-18) 41 | 42 | Features: 43 | - #170: Flycheck verify (Improved fsautocomplete diagnostics) 44 | 45 | Bugfixes: 46 | - #167: Fix error when visiting a new F# script file and 47 | fsautocomplete is not started 48 | - #168: Add Flycheck predicate function to prevent error when 49 | fsautocomplete is not running 50 | - #162: Stop matching [ as part of normal residue 51 | - #157: Don't change global value of `comment-indent-function' 52 | - #153: Add access control keywords to declaration regexes 53 | 54 | ## 1.9.11 (2017-10-21) 55 | 56 | Features: 57 | - #151: Correctly find MSBuild from VS2017 58 | 59 | Bugfixes: 60 | - #152: Handle failure to find build commands gracefully 61 | 62 | ## 1.9.10 (2017-09-18) 63 | 64 | Bugfixes: 65 | - #146: Understand FSAC 0.34 error msgs 66 | 67 | ## 1.9.9 (2017-09-15) 68 | 69 | Features 70 | - #143: Update to FsAutoComplete 0.34.0 71 | 72 | Bugfixes: 73 | - #139: Disable flycheck and fsharp-doc-mode when fsharp-ac-intellisense-enabled is nil 74 | 75 | ## 1.9.8 (2017-06-17) 76 | 77 | Features: 78 | - #134: Improved logging 79 | - #137: fsharp-shift-region-[left,right]: change bindings to 'C-c <' and 'C-c >' 80 | 81 | Bugfixes: 82 | - #136: Use correct F# interactive prompt regex 83 | 84 | ## 1.9.7 (2017-06-06) 85 | 86 | Bugfixes: 87 | - #131: Don't panic on malformed JSON (debug messages) 88 | - #133: Update faceup to capture font-locking <| 89 | 90 | ## 1.9.6 (2017-04-16) 91 | 92 | Features: 93 | - #127: Update to FsAutoComplete 0.32.0 (.NET Core project support) 94 | 95 | Bugfixes: 96 | - #125: Small fixes to try to prevent fsharp-mode to freeze all emacs 97 | - #122: Make fsharp-doc-mode hook buffer-local 98 | 99 | ## 1.9.5 (2017-01-21) 100 | 101 | Bugfixes: 102 | - #117: Fix `type` locking 103 | - #118: Don't change company-idle-delay 104 | - #120: Fix FSAC hanging issue 105 | 106 | ## 1.9.4 (2016-11-30) 107 | 108 | Features 109 | - #116: Improve Active Pattern font locking, eval-when-compile the main font-lock-keywords form 110 | - #114: Clean up font-locking code 111 | 112 | ## 1.9.3 (2016-10-31) 113 | Features 114 | - #111: Update to FsAutoComplete 0.32.0 115 | - #109: Define inferior-fsharp-mode as variant of comint mode 116 | 117 | Bugfixes: 118 | - #110: Dont change default indent region function 119 | - #105: Don't send trailing newline to fsautocomplete 120 | - #104: Dont change `company-minimum-prefix-length' 121 | 122 | ## 1.9.2 (2016-09-30) 123 | Features 124 | - #98: Enable imenu support 125 | 126 | ## 1.9.1 (2016-07-19) 127 | 128 | Features: 129 | - Update to FsAutoComplete 0.29.0. 130 | 131 | ## 1.9.0 (2016-07-09) 132 | 133 | Features: 134 | - #71: fontify the doc string (@nosami). 135 | - #77: Use new typesig command for fsharp-doc mode (@rneatherway). 136 | - #88: Use flycheck for error reporting (@juergenhoetzel). 137 | 138 | Bugfixes: 139 | - #75: Do not change current buffer when starting FSI (@rneatherway). 140 | - #76: Record type highlighting (@rneatherway). 141 | - #79: Overlays should not grow when typing (@rneatherway). 142 | - #82: Inferior fsi: #silentcd to local directory in Tramp (@juergenhoetzel). 143 | - #83: Fix completion of type annotated symbols (@juergenhoetzel). 144 | - #85: Don't modify company-transformers (@nosami). 145 | - #86: Don't clobber company-backends (@nosami). 146 | 147 | ## 1.8.1 (2016-04-14) 148 | 149 | Features: 150 | - #66: Tramp support (@juergenhoetzel). 151 | - #69: Prefer exact case sort in completion list (@nosami). 152 | 153 | ## 1.8.0 (2016-04-05) 154 | 155 | Features: 156 | - Update to FsAutoComplete 0.28.0 to support #65. 157 | - #65: Faster completions (thanks to @nosami). 158 | - #56: Use FsAutoComplete "startswith" filter (thanks to @juergenhoetzel). 159 | 160 | Bugfixes: 161 | - #67: Fix use of popup (thanks to @drvink) 162 | - #60: Unbreak company support on non-graphic displays (thanks to @drvink) 163 | - #58: Handle buffers not visiting a file (thanks to @juergenhoetzel). 164 | 165 | ## 1.7.4 (2016-02-05) 166 | 167 | Features: 168 | - #49: Use company for completions (thanks to @nosami). 169 | 170 | Bugfixes: 171 | - Update to FsAutoComplete 0.27.2, fixes project cracking for files 172 | with spaces in the path. 173 | 174 | ## 1.7.3 (2016-01-26) 175 | 176 | Bugfixes: 177 | - Update to FsAutoComplete 0.27.1, fixes Windows VS2015-only support. 178 | 179 | ## 1.7.2 (2016-01-08) 180 | 181 | Bugfixes: 182 | - #50: Inhibit electric-indent for fsharp-mode buffers (thanks to @joranvar). 183 | 184 | ## 1.7.1 (2015-11-24) 185 | 186 | Features: 187 | - #45: Update FSAC to 0.27, enable project cracking logs. 188 | 189 | ## 1.7.0 (2015-11-24) 190 | 191 | Features: 192 | - #34: Switch to SMIE-based indentation engine (thanks to m00nlight). 193 | - #31: Add highlighting of other usages of symbol at point. 194 | 195 | ## 1.6.3 (2015-10-24) 196 | 197 | Bugfixes: 198 | - Update to FsAutoComplete 0.26.1, which fixes Windows support. 199 | 200 | ## 1.6.2 (2015-10-20) 201 | 202 | Bugfixes: 203 | - Update to FsAutoComplete 0.26.0. 204 | - #30: Allow use of symbols containing '%' 205 | - #28: Fix FSI usage in buffers whose name differs from filename 206 | - #27: Fix test of fsharp-ac-debug 207 | 208 | ## 1.6.1 (2015-09-02) 209 | 210 | Bugfixes: 211 | - Update to FsAutoComplete 0.23.1. Fixed MSBuild v14 on non-English 212 | systems. 213 | 214 | ## 1.6.0 (2015-09-01) 215 | 216 | Features: 217 | - Update to FSharp.AutoComplete 0.23.0. Contains many improvements, 218 | which can be found in the changelog at 219 | https://github.com/fsharp/FsAutoComplete/releases 220 | - #20: Add C-x C-e as default keybinding for eval. 221 | - #22: Allow .fsx files to be compiled as well. 222 | 223 | Bugfixes: 224 | - #16: Remove BOM from process output. 225 | 226 | ## 1.5.4 (2015-06-04) 227 | 228 | Features: 229 | - #4: Update to FSharp.AutoComplete 0.18.0. All unsaved buffer 230 | contents (not just the current buffer) will now be used for type 231 | checking. 232 | 233 | Bugfixes: 234 | - #9: Correct quoting of path to fsi.exe on Windows. 235 | 236 | ## 1.5.3 (2015-05-26) 237 | 238 | Note that in since 1.5.2 fsharp-mode has been migrated from 239 | https://github.com/fsharp/fsharpbinding to a 240 | [separate repository](https://github.com/fsharp/emacs-fsharp-mode). 241 | The issue number `#2` below, and all future issue numbers, refer to the 242 | new repository. 243 | 244 | Features: 245 | - #993: Push the mark before going to definition (using etags) 246 | 247 | Bugfixes: 248 | - #1005: Fix issue with compile-command quoting 249 | - #2: Add `do!` as a keyword. 250 | 251 | ## 1.5.2 (2015-03-20) 252 | 253 | Bugfixes: 254 | - #973: Force comint-process-echoes to nil to avoid hangs 255 | 256 | ## 1.5.1 (2015-01-14) 257 | 258 | Bugfixes: 259 | - #923: Autocompletion not working on Emacs 24.4+ on Windows 260 | 261 | ## 1.5.0 (2014-11-25) 262 | 263 | Incorporate FSharp.AutoComplete version 0.13.3, which has corrected help text for the parse command and uses FCS 0.0.81. 264 | 265 | Features: 266 | - #235: Support multiple projects simultaneously 267 | 268 | Bugfixes: 269 | - #824: Emacs should give a better error message if fsautocomplete not found 270 | - #808: C-c C-p gives an error if no project file above current file's directory 271 | - #790: Can't make fsac requests in indirect buffers 272 | - #754: Compiler warnings when installing fsharp-mode from MELPA 273 | 274 | ## 1.4.2 (2014-10-30) 275 | 276 | Incorporate FSharp.AutoComplete version 0.13.2, which returns more information if the project parsing fails. 277 | 278 | Features: 279 | - #811: Return exception message on project parsing fail 280 | 281 | ## 1.4.1 (2014-10-30) 282 | 283 | Incorporate FSharp.AutoComplete version 0.13.1, which contains a fix for goto definition. 284 | 285 | Bugfixes: 286 | - #787: Correct off-by-one error in fsac goto definition 287 | 288 | ## 1.4.0 (2014-10-26) 289 | 290 | The main feature of this release is that the project parsing logic has 291 | been moved to FSharp.Compiler.Service as part of fixing #728. 292 | 293 | Features: 294 | - #319: Better error feedback when no completion data available 295 | - #720: Rationalise emacs testing, also fixed #453 296 | 297 | Bugfixes: 298 | - #765: Do not offer completions in irrelevant locations (strings/comments) 299 | - #721: Tests for Emacs syntax highlighting, and resultant fixes 300 | - #248: Run executable file now uses output from FSharp.AutoComplete 301 | - #728: Fix project support on Windows 302 | 303 | ## 1.3.0 (2014-08-28) 304 | 305 | Changes by @rneatherway unless otherwise noted. 306 | 307 | Major changes in this release are performance improvements thanks to @juergenhoetzel (avoiding parsing the current buffer unless necessary), and 308 | fixes for syntax highlighting. 309 | 310 | 311 | Features: 312 | - #481: Only parse the current buffer if it is was modified (@juergenhoetzel) 313 | 314 | Bugfixes: 315 | - #619: Disable FSI syntax highlighting 316 | - #670: Prevent double dots appearing during completion 317 | - #485: Fetch SSL certs before building exe in emacs dir 318 | - #496: Corrections to emacs syntax highlighting 319 | - #597: Highlight preprocessor and async 320 | - #605: Add FSI directives to syntax highlighting of emacs 321 | - #571: Correct range-check for emacs support 322 | - #572: Ensure fsi prompt is readonly 323 | - #452: Fetch SSL certs before building exe in emacs dir 324 | -------------------------------------------------------------------------------- /eglot-fsharp.el: -------------------------------------------------------------------------------- 1 | ;;; eglot-fsharp.el --- fsharp-mode eglot integration -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2019-2024 Jürgen Hötzel 4 | 5 | ;; Author: Jürgen Hötzel 6 | ;; Package-Requires: ((emacs "27.1") (eglot "1.4") (fsharp-mode "1.10") (jsonrpc "1.0.14")) 7 | ;; Version: 1.10 8 | ;; Keywords: languages 9 | ;; URL: https://github.com/fsharp/emacs-fsharp-mode 10 | 11 | ;; This program is free software; you can redistribute it and/or modify 12 | ;; it under the terms of the GNU General Public License as published by 13 | ;; the Free Software Foundation, either version 3 of the License, or 14 | ;; (at your option) any later version. 15 | 16 | ;; This program is distributed in the hope that it will be useful, 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 | ;; GNU General Public License for more details. 20 | 21 | ;; You should have received a copy of the GNU General Public License 22 | ;; along with this program. If not, see . 23 | 24 | ;;; Commentary: 25 | 26 | ;; Lua eglot introduced 27 | 28 | ;;; Code: 29 | 30 | (require 'eglot) 31 | (require 'fsharp-mode) 32 | (require 'gnutls) 33 | 34 | (defgroup eglot-fsharp nil 35 | "LSP support for the F# Programming Language, using F# compiler service." 36 | :link '(url-link "https://github.com/fsharp/FsAutoComplete") 37 | :group 'eglot) 38 | 39 | (defcustom eglot-fsharp-server-path "~/.dotnet/tools/" 40 | "Path to the location of FsAutoComplete." 41 | :group 'eglot-fsharp 42 | :risky t) 43 | 44 | (defcustom eglot-fsharp-server-install-dir 45 | (locate-user-emacs-file "FsAutoComplete/") 46 | "Install directory for FsAutoComplete." 47 | :group 'eglot-fsharp 48 | :risky t 49 | :type '(choice directory (const :tag "Use dotnet default for tool-path" nil))) 50 | 51 | (defcustom eglot-fsharp-server-version 'latest 52 | "FsAutoComplete version to install or update." 53 | :group 'eglot-fsharp 54 | :risky t 55 | :type '(choice 56 | (const :tag "Latest release" latest) 57 | (string :tag "Version string"))) 58 | 59 | (defcustom eglot-fsharp-server-args '("--adaptive-lsp-server-enabled") 60 | "Arguments for the fsautocomplete command when using `eglot-fsharp'." 61 | :type '(repeat string)) 62 | 63 | (defcustom eglot-fsharp-fsautocomplete-args '( 64 | :automaticWorkspaceInit t 65 | :abstractClassStubGeneration t 66 | :abstractClassStubGenerationMethodBody 67 | "failwith \"Not Implemented\"" 68 | :abstractClassStubGenerationObjectIdentifier "this" 69 | :addFsiWatcher nil 70 | :codeLenses (:references (:enabled t) 71 | :signature (:enabled t)) 72 | :disableFailedProjectNotifications nil 73 | :dotnetRoot "" 74 | :enableAdaptiveLspServer t 75 | :enableAnalyzers nil 76 | :enableMSBuildProjectGraph nil 77 | :enableReferenceCodeLens t 78 | :excludeProjectDirectories [".git" "paket-files" ".fable" "packages" "node_modules"] 79 | :externalAutocomplete nil 80 | :fsac (:attachDebugger nil 81 | :cachedTypeCheckCount 200 82 | :conserveMemory nil 83 | :dotnetArgs nil 84 | :netCoreDllPath "" 85 | :parallelReferenceResolution nil 86 | :silencedLogs nil) 87 | :fsiExtraParameters nil 88 | :fsiSdkFilePath "" 89 | :generateBinlog nil 90 | :indentationSize 4 91 | :inlayHints (:disableLongTooltip nil 92 | :enabled t 93 | :parameterNames t 94 | :typeAnnotations t) 95 | :inlineValues (:enabled nil 96 | :prefix "//") 97 | :interfaceStubGeneration t 98 | :interfaceStubGenerationMethodBody "failwith \"Not Implemented\"" 99 | :interfaceStubGenerationObjectIdentifier "this" 100 | :keywordsAutocomplete t 101 | :lineLens (:enabled "replaceCodeLens" 102 | :prefix " // ") 103 | :linter t 104 | :pipelineHints (:enabled t 105 | :prefix " // ") 106 | :recordStubGeneration t 107 | :recordStubGenerationBody "failwith \"Not Implemented\"" 108 | :resolveNamespaces t 109 | :saveOnSendLastSelection nil 110 | :simplifyNameAnalyzer t 111 | :smartIndent nil 112 | :suggestGitignore t 113 | :suggestSdkScripts t 114 | :unionCaseStubGeneration t 115 | :unionCaseStubGenerationBody "failwith \"Not Implemented\"" 116 | :unusedDeclarationsAnalyzer t 117 | :unusedOpensAnalyzer t 118 | :verboseLogging nil 119 | :workspaceModePeekDeepLevel 4 120 | :workspacePath "") 121 | "Arguments for the fsautocomplete workspace configuration." 122 | :group 'eglot-fsharp 123 | :risky t 124 | ) 125 | 126 | (defun eglot-fsharp--path-to-server () 127 | "Return FsAutoComplete path." 128 | (let ((base (if eglot-fsharp-server-install-dir 129 | (concat eglot-fsharp-server-install-dir "netcore/") 130 | eglot-fsharp-server-path))) 131 | (expand-file-name (concat base "fsautocomplete" (if (eq system-type 'windows-nt) ".exe" ""))))) 132 | 133 | ;; cache to prevent repetitive queries 134 | (defvar eglot-fsharp--latest-version nil "Latest fsautocomplete.exe version string.") 135 | 136 | (defun eglot-fsharp--latest-version () 137 | "Return latest fsautocomplete.exe version." 138 | (let* ((json (with-temp-buffer (url-insert-file-contents "https://azuresearch-usnc.nuget.org/query?q=fsautocomplete&prerelease=false&packageType=DotnetTool") 139 | (json-parse-buffer))) 140 | (versions (gethash "versions" (aref (gethash "data" json) 0)))) 141 | (gethash "version" (aref versions (1- (length versions)))))) 142 | 143 | (defun eglot-fsharp--installed-version () 144 | "Return version string of fsautocomplete." 145 | (with-temp-buffer 146 | (if eglot-fsharp-server-install-dir 147 | (process-file "dotnet" nil t nil "tool" "list" "--tool-path" (file-name-directory (eglot-fsharp--path-to-server))) 148 | (process-file "dotnet" nil t nil "tool" "list" "-g")) 149 | (goto-char (point-min)) 150 | (when (search-forward-regexp "^fsautocomplete[[:space:]]+\\([0-9\.]*\\)[[:space:]]+" nil t) 151 | (match-string 1)))) 152 | 153 | (defun eglot-fsharp-current-version-p (version) 154 | "Return t if the installation is up-to-date compared to VERSION string." 155 | (and (file-exists-p (concat (file-remote-p default-directory) (eglot-fsharp--path-to-server))) 156 | (equal version (eglot-fsharp--installed-version)))) 157 | 158 | (defun eglot-fsharp--install-core (version) 159 | "Download and install fsautocomplete as a dotnet tool at version VERSION in `eglot-fsharp-server-install-dir'." 160 | (let* ((default-directory (concat (file-remote-p default-directory) 161 | (file-name-directory (eglot-fsharp--path-to-server)))) 162 | (stderr-file (make-temp-file "dotnet_stderr")) 163 | (local-tool-path (or (file-remote-p default-directory 'localname) default-directory)) 164 | (process-file-uninstall-args (if eglot-fsharp-server-install-dir 165 | (list "dotnet" nil `(nil ,stderr-file) nil "tool" "uninstall" "fsautocomplete" "--tool-path" local-tool-path) 166 | (list "dotnet" nil `(nil ,stderr-file) nil "tool" "uninstall" "-g" "fsautocomplete"))) 167 | (process-file-install-args (if eglot-fsharp-server-install-dir 168 | (list "dotnet" nil `(nil ,stderr-file) nil "tool" "install" "fsautocomplete" "--tool-path" local-tool-path "--version" version) 169 | (list "dotnet" nil `(nil ,stderr-file) nil "tool" "install" "fsautocomplete" "-g" "--version" version)))) 170 | (make-directory default-directory t) 171 | (condition-case err 172 | (progn 173 | (unless (or (eglot-fsharp-current-version-p version) (not (eglot-fsharp--installed-version))) 174 | (message "Uninstalling fsautocomplete version %s" (eglot-fsharp--installed-version)) 175 | (unless (zerop (apply #'process-file process-file-uninstall-args)) 176 | (error "'dotnet tool uninstall fsautocomplete ... failed"))) 177 | (unless (zerop (apply #'process-file process-file-install-args)) 178 | (error "'dotnet tool install fsautocomplete --tool-path %s --version %s' failed" default-directory version))) 179 | (error 180 | (let ((stderr (with-temp-buffer 181 | (insert-file-contents stderr-file) 182 | (buffer-string)))) 183 | (delete-file stderr-file) 184 | (signal (car err) (format "%s: %s" (cdr err) stderr))))) 185 | (message "Installed fsautocomplete to %s" (eglot-fsharp--path-to-server)))) 186 | 187 | (defun eglot-fsharp--maybe-install (&optional version) 188 | "Downloads F# compiler service, and install in `eglot-fsharp-server-install-dir'." 189 | (unless eglot-fsharp-server-install-dir 190 | (make-directory (concat (file-remote-p default-directory) 191 | (file-name-directory (eglot-fsharp--path-to-server))) t)) 192 | (let* ((version (or version (if (eq eglot-fsharp-server-version 'latest) 193 | (eglot-fsharp--latest-version) 194 | eglot-fsharp-server-version)))) 195 | (unless (eglot-fsharp-current-version-p version) 196 | (eglot-fsharp--install-core version)))) 197 | 198 | ;;;###autoload 199 | (defun eglot-fsharp (interactive) 200 | "Return `eglot' contact when FsAutoComplete is installed. 201 | Ensure FsAutoComplete is installed (when called INTERACTIVE)." 202 | (when interactive (eglot-fsharp--maybe-install)) 203 | (cons 'eglot-fsautocomplete 204 | (if (file-remote-p default-directory) 205 | `("sh" ,shell-command-switch ,(concat "cat|" (mapconcat #'shell-quote-argument 206 | (cons (eglot-fsharp--path-to-server) eglot-fsharp-server-args) " "))) 207 | (cons (eglot-fsharp--path-to-server) eglot-fsharp-server-args)))) 208 | 209 | 210 | (defclass eglot-fsautocomplete (eglot-lsp-server) () 211 | :documentation "F# FsAutoComplete langserver.") 212 | 213 | (cl-defmethod eglot-initialization-options ((_server eglot-fsautocomplete)) 214 | "Passes through required FsAutoComplete initialization options." 215 | eglot-fsharp-fsautocomplete-args) 216 | 217 | ;; FIXME: this should be fixed in FsAutocomplete 218 | (cl-defmethod xref-backend-definitions :around ((_type symbol) _identifier) 219 | "FsAutoComplete breaks spec and and returns error instead of empty list." 220 | (if (eq major-mode 'fsharp-mode) 221 | (condition-case err 222 | (cl-call-next-method) 223 | (jsonrpc-error 224 | (not (equal (cadddr err) '(jsonrpc-error-message . "Could not find declaration"))))) 225 | (when (cl-next-method-p) 226 | (cl-call-next-method)))) 227 | 228 | (add-to-list 'eglot-server-programs `(fsharp-mode . eglot-fsharp)) 229 | 230 | (provide 'eglot-fsharp) 231 | ;;; eglot-fsharp.el ends here 232 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | 179 | APPENDIX: How to apply the Apache License to your work. 180 | 181 | To apply the Apache License to your work, attach the following 182 | boilerplate notice, with the fields enclosed by brackets "[]" 183 | replaced with your own identifying information. (Don't include 184 | the brackets!) The text should be enclosed in the appropriate 185 | comment syntax for the file format. We also recommend that a 186 | file or class name and description of purpose be included on the 187 | same "printed page" as the copyright notice for easier 188 | identification within third-party archives. 189 | 190 | Copyright [yyyy] [name of copyright owner] 191 | 192 | Licensed under the Apache License, Version 2.0 (the "License"); 193 | you may not use this file except in compliance with the License. 194 | You may obtain a copy of the License at 195 | 196 | http://www.apache.org/licenses/LICENSE-2.0 197 | 198 | Unless required by applicable law or agreed to in writing, software 199 | distributed under the License is distributed on an "AS IS" BASIS, 200 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 201 | See the License for the specific language governing permissions and 202 | limitations under the License. 203 | -------------------------------------------------------------------------------- /test/apps/FQuake3/NativeMappings.fs.faceup: -------------------------------------------------------------------------------- 1 | «x:(* 2 | Copyright (C) 2013 William F. Smith 3 | 4 | This program is free software; you can redistribute it 5 | and/or modify it under the terms of the GNU General Public License as 6 | published by the Free Software Foundation; either version 2 of the License, 7 | or (at your option) any later version. 8 | 9 | This program is distributed in the hope that it will be 10 | useful, but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | GNU General Public License for more details. 13 | 14 | You should have received a copy of the GNU General Public License 15 | along with this program; if not, write to the Free Software 16 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 17 | 18 | Derivative of Quake III Arena source: 19 | Copyright (C) 1999-2005 Id Software, Inc. 20 | *)» 21 | 22 | «m:// »«x:Disable native interop warnings 23 | »«k:#nowarn» «s:"9"» 24 | «k:#nowarn» «s:"51"» 25 | 26 | «k:namespace» «v:Engine».«v:Native» 27 | 28 | «k:open» «v:System» 29 | «k:open» «v:System».«v:IO» 30 | «k:open» «v:System».«v:Runtime».«v:InteropServices» 31 | «k:open» «v:Microsoft».«v:FSharp».«v:NativeInterop» 32 | «k:open» «v:FSharp».«v:Game».«v:Math» 33 | «k:open» «v:Engine».«v:Core» 34 | «k:open» «v:Engine».«v:Net» 35 | «k:open» «v:Engine».«v:FileSystem» 36 | «k:open» «v:Engine».«v:NativeInterop» 37 | «k:open» «v:FQuake3».«v:Math» 38 | «k:open» «v:FQuake3».«v:Md3» 39 | 40 | «m:/// »«x:Used to prevent massive copying of large immutable data. 41 | »«k:module» «k:private» «v:Cache» = 42 | «k:let» «k:mutable» «v:md3Map» = Map.empty 43 | 44 | «k:module» «t:Boolean» = 45 | «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = 46 | «k:let» «k:mutable» «v:native» = NativePtr.read ptr 47 | 48 | «k:match» native «k:with» 49 | «:fsharp-ui-operator-face:|» qboolean.qtrue -> «k:true» 50 | «:fsharp-ui-operator-face:|» _ -> «k:false» 51 | 52 | «k:let» «k:inline» «f:toNativeByPtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») («v:value»: «t:bool») = 53 | «k:let» «k:mutable» «v:native» = NativePtr.read ptr 54 | 55 | native <- «k:if» value «k:then» qboolean.qtrue «k:else» qboolean.qfalse 56 | 57 | NativePtr.write ptr native 58 | 59 | «k:let» «k:inline» «f:toNative» («v:value»: «t:bool») = 60 | «k:if» value «k:then» qboolean.qtrue «k:else» qboolean.qfalse 61 | 62 | «k:module» «t:Vec2» = 63 | «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = 64 | «k:let» «k:mutable» «v:native» = NativePtr.read ptr 65 | 66 | vec2 (native.value, native.value1) 67 | 68 | «k:let» «k:inline» «f:toNativeByPtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») («v:v»: «t:vec2») = 69 | «k:let» «k:mutable» «v:native» = NativePtr.read ptr 70 | 71 | native.value <- v.X 72 | native.value1 <- v.Y 73 | 74 | NativePtr.write ptr native 75 | 76 | «k:module» «t:Vec3» = 77 | «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = 78 | «k:let» «k:mutable» «v:native» = NativePtr.read ptr 79 | 80 | vec3 (native.value, native.value1, native.value2) 81 | 82 | «k:let» «k:inline» «f:toNativeByPtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») («v:v»: «t:vec3») = 83 | «k:let» «k:mutable» «v:native» = NativePtr.read ptr 84 | 85 | native.value <- v.X 86 | native.value1 <- v.Y 87 | native.value2 <- v.Z 88 | 89 | NativePtr.write ptr native 90 | 91 | «k:module» «t:Vec4» = 92 | «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = 93 | «k:let» «k:mutable» «v:native» = NativePtr.read ptr 94 | 95 | vec4 (native.value, native.value1, native.value2, native.value3) 96 | 97 | «k:let» «k:inline» «f:toNativeByPtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») («v:v»: «t:vec4») = 98 | «k:let» «k:mutable» «v:native» = NativePtr.read ptr 99 | 100 | native.value <- v.X 101 | native.value1 <- v.Y 102 | native.value2 <- v.Z 103 | native.value3 <- v.W 104 | 105 | NativePtr.write ptr native 106 | 107 | «k:module» «t:Mat4» = 108 | «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = 109 | mat4 ( 110 | (NativePtr.get ptr 0), 111 | (NativePtr.get ptr 1), 112 | (NativePtr.get ptr 2), 113 | (NativePtr.get ptr 3), 114 | (NativePtr.get ptr 4), 115 | (NativePtr.get ptr 5), 116 | (NativePtr.get ptr 6), 117 | (NativePtr.get ptr 7), 118 | (NativePtr.get ptr 8), 119 | (NativePtr.get ptr 9), 120 | (NativePtr.get ptr 10), 121 | (NativePtr.get ptr 11), 122 | (NativePtr.get ptr 12), 123 | (NativePtr.get ptr 13), 124 | (NativePtr.get ptr 14), 125 | (NativePtr.get ptr 15) 126 | ) 127 | 128 | «k:let» «k:inline» «f:toNativeByPtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») («v:m»: «t:mat4») = 129 | NativePtr.set ptr 0 m.[0, 0] 130 | NativePtr.set ptr 1 m.[0, 1] 131 | NativePtr.set ptr 2 m.[0, 2] 132 | NativePtr.set ptr 3 m.[0, 3] 133 | NativePtr.set ptr 4 m.[1, 0] 134 | NativePtr.set ptr 5 m.[1, 1] 135 | NativePtr.set ptr 6 m.[1, 2] 136 | NativePtr.set ptr 7 m.[1, 3] 137 | NativePtr.set ptr 8 m.[2, 0] 138 | NativePtr.set ptr 9 m.[2, 1] 139 | NativePtr.set ptr 10 m.[2, 2] 140 | NativePtr.set ptr 11 m.[2, 3] 141 | NativePtr.set ptr 12 m.[3, 0] 142 | NativePtr.set ptr 13 m.[3, 1] 143 | NativePtr.set ptr 14 m.[3, 2] 144 | NativePtr.set ptr 15 m.[3, 3] 145 | 146 | «k:module» «t:Cvar» = 147 | «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = 148 | «k:let» «k:mutable» «v:native» = NativePtr.read ptr 149 | 150 | { 151 | Name = NativePtr.toStringAnsi native.name; 152 | String = NativePtr.toStringAnsi native.string; 153 | ResetString = NativePtr.toStringAnsi native.resetString; 154 | LatchedString = NativePtr.toStringAnsi native.latchedString; 155 | Flags = native.flags; 156 | IsModified = Boolean.ofNativePtr &&native.modified; 157 | ModificationCount = native.modificationCount; 158 | Value = native.value; 159 | Integer = native.integer; 160 | } 161 | 162 | «k:module» «t:Bounds» = 163 | «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = 164 | Bounds ( 165 | Vec3.ofNativePtr «:fsharp-ui-operator-face:<|» NativePtr.add ptr 0, 166 | Vec3.ofNativePtr «:fsharp-ui-operator-face:<|» NativePtr.add ptr 1) 167 | 168 | «k:let» «k:inline» «f:toNativeByPtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») («v:bounds»: «t:Bounds») = 169 | «k:let» «k:mutable» «v:nativeX» = NativePtr.get ptr 0 170 | «k:let» «k:mutable» «v:nativeY» = NativePtr.get ptr 1 171 | 172 | Vec3.toNativeByPtr &&nativeX bounds.Min 173 | Vec3.toNativeByPtr &&nativeY bounds.Max 174 | 175 | NativePtr.set ptr 0 nativeX 176 | NativePtr.set ptr 1 nativeY 177 | 178 | «k:module» «t:Message» = 179 | «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = 180 | «k:let» «k:mutable» «v:native» = NativePtr.read ptr 181 | 182 | { 183 | IsAllowedOverflow = Boolean.ofNativePtr &&native.allowoverflow; 184 | IsOverflowed = Boolean.ofNativePtr &&native.overflowed; 185 | IsOutOfBand = Boolean.ofNativePtr &&native.oob; 186 | Data = Seq.ofNativePtrArray native.cursize native.data; 187 | MaxSize = native.maxsize; 188 | ReadCount = native.readcount; 189 | Bit = native.bit; 190 | } 191 | 192 | «k:module» «t:IPAddress» = 193 | «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = 194 | { 195 | Octet1 = NativePtr.get ptr 0; 196 | Octet2 = NativePtr.get ptr 1; 197 | Octet3 = NativePtr.get ptr 2; 198 | Octet4 = NativePtr.get ptr 3; 199 | } 200 | 201 | «k:module» «t:Address» = 202 | «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = 203 | «k:let» «k:mutable» «v:native» = NativePtr.read ptr 204 | 205 | { 206 | Type = enum (int native.type'); 207 | IP = IPAddress.ofNativePtr &&native.ip 208 | Port = native.port; 209 | } 210 | 211 | «k:module» «t:Md3Frame» = 212 | «k:let» «k:inline» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = 213 | «k:let» «k:mutable» «v:native» = NativePtr.read ptr 214 | 215 | { 216 | Bounds = Bounds.ofNativePtr &&native.bounds; 217 | LocalOrigin = Vec3.ofNativePtr &&native.localOrigin; 218 | Radius = native.radius; 219 | Name = NativePtr.toStringAnsi &&native.name; 220 | } 221 | 222 | «k:module» «t:Md3» = 223 | «k:let» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = 224 | «k:let» «k:mutable» «v:native» = NativePtr.read ptr 225 | 226 | «k:let» «v:hash» = NativePtr.toNativeInt ptr 227 | 228 | «k:match» Map.tryFind hash Cache.md3Map «k:with» 229 | «:fsharp-ui-operator-face:|» Some x -> x 230 | «:fsharp-ui-operator-face:|» None -> 231 | 232 | «k:let» «v:bytes» = Array.zeroCreate native.ofsEnd 233 | Marshal.Copy (NativePtr.toNativeInt ptr, bytes, 0, native.ofsEnd) 234 | «k:let» «v:md3» = FQuake3.Utils.Md3.parse bytes 235 | Cache.md3Map <- Map.add hash md3 Cache.md3Map 236 | md3 237 | 238 | «k:module» «t:DirectoryInfo» = 239 | «k:let» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = 240 | «k:let» «k:mutable» «v:native» = NativePtr.read ptr 241 | 242 | «k:let» «v:path» = NativePtr.toStringAnsi &&native.path 243 | «k:let» «v:name» = NativePtr.toStringAnsi &&native.gamedir 244 | 245 | DirectoryInfo (Path.Combine (path, name)) 246 | 247 | «k:module» «t:Pak» = 248 | «k:let» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = 249 | «k:let» «k:mutable» «v:native» = NativePtr.read ptr 250 | 251 | { 252 | FileInfo = FileInfo (NativePtr.toStringAnsi &&native.pakFilename); 253 | Checksum = native.checksum; 254 | PureChecksum = native.checksum; 255 | FileCount = native.numfiles; 256 | } 257 | 258 | «k:module» «t:ServerPakChecksum» = 259 | «k:let» «f:createFrom_fs_serverPaks» («v:size»: «t:int») («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = 260 | «k:match» NativePtr.isValid ptr «k:with» 261 | «:fsharp-ui-operator-face:|» «k:false» -> [] 262 | «:fsharp-ui-operator-face:|» _ -> NativePtr.toList size ptr 263 | 264 | «k:module» «t:SearchPath» = 265 | «k:let» «f:ofNativePtr» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = 266 | «k:let» «k:mutable» «v:native» = NativePtr.read ptr 267 | 268 | { 269 | DirectoryInfo = Option.ofNativePtr DirectoryInfo.ofNativePtr native.directory 270 | } 271 | 272 | «k:let» «f:convertFrom_fs_searchpaths» («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = 273 | «k:let» «k:rec» «f:f» («v:searchPaths»: «t:SearchPath list») («v:ptr»: «t:nativeptr»«:fsharp-ui-generic-face:») = 274 | «k:match» NativePtr.isValid ptr «k:with» 275 | «:fsharp-ui-operator-face:|» «k:false» -> searchPaths 276 | «:fsharp-ui-operator-face:|» _ -> 277 | «k:let» «k:mutable» «v:native» = NativePtr.read ptr 278 | f (ofNativePtr ptr :: searchPaths) (native.next) 279 | 280 | f [] ptr 281 | -------------------------------------------------------------------------------- /test/fsharp-mode-structure-tests.el: -------------------------------------------------------------------------------- 1 | ;;; fsharp-mode-structure-tests.el --- -*- lexical-binding: t; -*- 2 | 3 | (require 'buttercup) 4 | 5 | (require 'fsharp-mode) 6 | (require 'fsharp-mode-structure) 7 | 8 | (defvar fsharp-struct-test-files-dir "test/StructureTest/") 9 | 10 | ;;-------------------------------- Regex Tests --------------------------------;; 11 | 12 | (ert-deftest fsharp-stringlit-re-test ()) 13 | 14 | ;;--------------------------- Structure Navigation ---------------------------;; 15 | ;; TODO[gastove|2019-10-31] This function turns out to be incredibly broken! It 16 | ;; wont move past the final line of _most_ multi-line expressions. Wonderful. 17 | ;; 18 | ;; This will get fixed in the next PR. 19 | ;; (ert-deftest fsharp-goto-beyond-final-line-test () 20 | ;; (let ((blocks-file (file-truename (concat fsharp-struct-test-files-dir "Blocks.fs")))) 21 | ;; (using-file blocks-file 22 | ;; ;; A single-line expression 23 | ;; (goto-char 1) 24 | ;; (fsharp-goto-beyond-final-line) 25 | ;; (should (eq (point) 19)) 26 | 27 | ;; ;; A multi-line expression using a pipe. We should wind up in the same 28 | ;; ;; place whether we start at the beginning or the end of the expression. 29 | ;; (goto-char 20) 30 | ;; (fsharp-goto-beyond-final-line) 31 | ;; (should (eq (point) 88)) 32 | ;; (goto-char 46) 33 | ;; (fsharp-goto-beyond-final-line) 34 | ;; (should (eq (point) 88)) 35 | 36 | ;; ;; A multi-line discriminated union. 37 | ;; (goto-char 89) 38 | ;; (fsharp-goto-beyond-final-line) 39 | ;; (should (eq (point) 146)) 40 | ;; (goto-char 122) 41 | ;; (fsharp-goto-beyond-final-line) 42 | ;; (should (eq (point) 146)) 43 | 44 | ;; ;; A function using an if/else block 45 | ;; (goto-char 147) 46 | ;; (fsharp-goto-beyond-final-line) 47 | ;; (should (eq (point) 218)) 48 | ;; (goto-char 171) 49 | ;; (fsharp-goto-beyond-final-line) 50 | ;; (should (eq (point) 218)) 51 | ;; ))) 52 | 53 | ;;-------------------------------- Predicates --------------------------------;; 54 | 55 | (describe "The `fsharp-backslash-continuation-line-p' predicate" 56 | (it "returns true when we expect it to" 57 | (let ((file (file-truename (concat fsharp-struct-test-files-dir "ContinuationLines.fs")))) 58 | (with-current-buffer (find-file-noselect file) 59 | (beginning-of-buffer) 60 | (should (eq (fsharp--hanging-operator-continuation-line-p) nil)) 61 | (forward-line 1) 62 | (should (eq (fsharp--hanging-operator-continuation-line-p) nil)) 63 | (forward-line 5) 64 | (should (eq (fsharp--hanging-operator-continuation-line-p) t)))))) 65 | 66 | (describe "The `fsharp-in-literal-p'" 67 | (it "return non-nil in both strings and comments?" 68 | (let ((literals-file (file-truename (concat fsharp-struct-test-files-dir "Literals.fs")))) 69 | (with-current-buffer (find-file-noselect literals-file) 70 | ;; Comments 71 | (goto-char 3) 72 | (should (eq (fsharp-in-literal-p) 'comment)) 73 | (goto-char 642) 74 | (should (eq (fsharp-in-literal-p) 'comment)) 75 | (goto-char 968) 76 | (should (eq (fsharp-in-literal-p) 'comment)) 77 | (goto-char 1481) 78 | (should (eq (fsharp-in-literal-p) 'comment)) 79 | (goto-char 2124) 80 | (should (eq (fsharp-in-literal-p) 'comment)) 81 | ;; String literals 82 | (goto-char 2717) 83 | (should (eq (fsharp-in-literal-p) 'string)) 84 | ;; This string contains an inner, backslash-escaped string. 85 | ;; First, with point outside the backslash-escaped string: 86 | (goto-char 2759) 87 | (should (eq (fsharp-in-literal-p) 'string)) 88 | ;; ...and now with point inside it 89 | (goto-char 2774) 90 | (should (eq (fsharp-in-literal-p) 'string)) 91 | ;; Inside triple-quoted strings 92 | (goto-char 2835) 93 | (should (eq (fsharp-in-literal-p) 'string)) 94 | (goto-char 2900) 95 | (should (eq (fsharp-in-literal-p) 'string)))))) 96 | 97 | ;; NOTE[gastove|2019-10-31] I am entirely convinced this doesn't work precisely 98 | ;; as it should, because it depends on `fsharp-goto-beyond-final-line', which I 99 | ;; am positive is buggy. 100 | ;; 101 | ;; Udate: yep! It's buggy! Will uncomment and fix in the next PR. 102 | ;; (ert-deftest fsharp-statement-opens-block-p-test () 103 | ;; "Does `fsharp-statement-opens-block-p' correctly detect block-opening statements?" 104 | ;; (let ((blocks-file (file-truename (concat fsharp-struct-test-files-dir "Blocks.fs")))) 105 | ;; (using-file blocks-file 106 | ;; (goto-char 1) 107 | ;; (should-not (fsharp-statement-opens-block-p)) 108 | ;; (goto-char 20) 109 | ;; (should (fsharp-statement-opens-block-p)) 110 | ;; (goto-char 89) 111 | ;; (should (fsharp-statement-opens-block-p))))) 112 | 113 | ;;--------------------- Nesting and Indentation Functions ---------------------;; 114 | 115 | (describe "The `fsharp-nesting-level' function" 116 | (it "returns nil when we expect it to" 117 | (with-temp-buffer 118 | (insert "let x = 5") 119 | (end-of-buffer) 120 | (should (eq (fsharp-nesting-level) nil))))) 121 | 122 | (describe "The `fsharp-nesting-level' function" 123 | :var ((file (file-truename (concat fsharp-struct-test-files-dir "Nesting.fs")))) 124 | (it "correctly return the point position of the opening pair closest to point" 125 | ;; The character positions use here reference characters noted in comments in Nesting.fs 126 | ;; Test a normal list 127 | (with-current-buffer (find-file-noselect file) 128 | (goto-char 645) 129 | (should (eq (fsharp-nesting-level) 640))) 130 | 131 | ;; Get the opening bracket of an inner list from a single-line nested list 132 | (with-current-buffer (find-file-noselect file) 133 | (goto-char 717) 134 | (should (eq (fsharp-nesting-level) 706))) 135 | 136 | ;; Opening bracket for a multi-line non-nested list 137 | (with-current-buffer (find-file-noselect file) 138 | (goto-char 795) 139 | (should (eq (fsharp-nesting-level) 777))) 140 | 141 | ;; Inner most opening bracket for a multi-line multi-nested list 142 | (with-current-buffer (find-file-noselect file) 143 | (goto-char 960) 144 | (should (eq (fsharp-nesting-level) 955))) 145 | ;; Middle opening bracket for same list as previous 146 | (with-current-buffer (find-file-noselect file) 147 | (goto-char 954) 148 | (should (eq (fsharp-nesting-level) 953))) 149 | (with-current-buffer (find-file-noselect file) 150 | (goto-char 974) 151 | (should (eq (fsharp-nesting-level) 953))) 152 | ;; Outermost opening bracket for same list 153 | (with-current-buffer (find-file-noselect file) 154 | (goto-char 977) 155 | (should (eq (fsharp-nesting-level) 947))) 156 | 157 | ;; Basic Async form, should return the opening { 158 | (with-current-buffer (find-file-noselect file) 159 | (goto-char 1088) 160 | (should (eq (fsharp-nesting-level) 1060))) 161 | ;; Same async form, inner async call 162 | (with-current-buffer (find-file-noselect file) 163 | (goto-char 1129) 164 | (should (eq (fsharp-nesting-level) 1121))) 165 | 166 | ;; Lambda, wrapped in parens, should return the opening ( 167 | (with-current-buffer (find-file-noselect file) 168 | (goto-char 1238) 169 | (should (eq (fsharp-nesting-level) 1208))))) 170 | 171 | 172 | (describe "The `fsharp--compute-indentaiton-open-bracket'" 173 | :var ((file (file-truename (concat fsharp-struct-test-files-dir "BracketIndent.fs")))) 174 | (it "returns the correct indentation in a variety of cases" 175 | (with-current-buffer (find-file-noselect file) 176 | ;; Opening bracket on same line as let, elements on same line; test element 177 | (goto-char 44) 178 | (let* ((nesting-level (fsharp-nesting-level)) 179 | (indent-at-point (fsharp--compute-indentation-open-bracket nesting-level))) 180 | ;; The value we expect 181 | (should (eq indent-at-point 18)) 182 | ;; Both entrypoints should have the same answer 183 | (should (eq indent-at-point (fsharp-compute-indentation t)))) 184 | 185 | ;; Opening bracket on same line as let, elements on same line; test newline 186 | (goto-char 81) 187 | (let* ((nesting-level (fsharp-nesting-level)) 188 | (indent-at-point (fsharp--compute-indentation-open-bracket nesting-level))) 189 | ;; The value we expect 190 | (should (eq indent-at-point 18)) 191 | ;; Both entrypoints should have the same answer 192 | (should (eq indent-at-point (fsharp-compute-indentation t)))) 193 | 194 | ;; Opening bracket on same line as let, elements on new line; test element 195 | (goto-char 148) 196 | (let* ((nesting-level (fsharp-nesting-level)) 197 | (indent-at-point (fsharp--compute-indentation-open-bracket nesting-level))) 198 | (should (eq indent-at-point 4)) 199 | (should (eq indent-at-point (fsharp-compute-indentation t)))) 200 | 201 | ;; Opening bracket on same line as let, elements on new line; test newline 202 | (goto-char 155) 203 | (let* ((nesting-level (fsharp-nesting-level)) 204 | (indent-at-point (fsharp--compute-indentation-open-bracket nesting-level))) 205 | (should (eq indent-at-point 4)) 206 | (should (eq indent-at-point (fsharp-compute-indentation t)))) 207 | 208 | ;; Opening bracket on own line; test element 209 | (goto-char 231) 210 | (let* ((nesting-level (fsharp-nesting-level)) 211 | (indent-at-point (fsharp--compute-indentation-open-bracket nesting-level))) 212 | (should (eq indent-at-point 6)) 213 | (should (eq indent-at-point (fsharp-compute-indentation t)))) 214 | 215 | ;; Opening bracket on own line; test newline 216 | (goto-char 236) 217 | (let* ((nesting-level (fsharp-nesting-level)) 218 | (indent-at-point (fsharp--compute-indentation-open-bracket nesting-level))) 219 | (should (eq indent-at-point 6)) 220 | (should (eq indent-at-point (fsharp-compute-indentation t))))))) 221 | 222 | 223 | (describe "The `fsharp--compute-indentation-continuation-line' function" 224 | :var ((continuation-line "let x = 5 +")) 225 | (it "indents correctly" 226 | (with-temp-buffer 227 | (fsharp-mode) 228 | (insert continuation-line) 229 | (fsharp-newline-and-indent) 230 | (should (eq (fsharp--compute-indentation-continuation-line) 8)) 231 | (should (eq (fsharp--compute-indentation-continuation-line) (fsharp-compute-indentation t)))))) 232 | 233 | 234 | (describe "The `fsharp-compute-indentation-relative-to-previous' function'" 235 | :var ((file (concat fsharp-struct-test-files-dir "Relative.fs"))) 236 | (it "indents correctly releative to previous line" 237 | ;; Discriminated unions 238 | (with-current-buffer (find-file-noselect file) 239 | (goto-char 57) 240 | (should (eq (fsharp--compute-indentation-relative-to-previous t) 4)) 241 | (should (eq (fsharp--compute-indentation-relative-to-previous t) 242 | (fsharp-compute-indentation t))) 243 | 244 | ;; If/Else blocks 245 | ;; if an if then are on the same line, the next line is indented 246 | (goto-char 96) 247 | (should (eq (fsharp--compute-indentation-relative-to-previous t) 4)) 248 | (should (eq (fsharp--compute-indentation-relative-to-previous t) 249 | (fsharp-compute-indentation t))) 250 | 251 | ;; An else is not indented further; *however*, the indentation relative to 252 | ;; previous will be 4, but `fsharp-compute-indentation' will return 0 253 | ;; because the previous line is not a continuation line. 254 | ;; 255 | ;; However! This test case doesn't currently work. Indentation code 256 | ;; produces indent of 0, but the compute indentation functions proudce an 257 | ;; indent of 4, which is wrong. 258 | ;; 259 | ;; (goto-char 124) 260 | ;; (should (eq (fsharp--compute-indentation-relative-to-previous t) 4)) 261 | ;; (should-not (eq (fsharp--compute-indentation-relative-to-previous t) 262 | ;; (fsharp-compute-indentation t))) 263 | 264 | ;; when a then is on its own line, the next line is indented 265 | (goto-char 154) 266 | (should (eq (fsharp--compute-indentation-relative-to-previous t) 4)) 267 | (should (eq (fsharp--compute-indentation-relative-to-previous t) 268 | (fsharp-compute-indentation t))) 269 | ;; likewise an else 270 | (goto-char 180) 271 | (should (eq (fsharp--compute-indentation-relative-to-previous t) 4)) 272 | (should (eq (fsharp--compute-indentation-relative-to-previous t) 273 | (fsharp-compute-indentation t)))))) 274 | 275 | (describe "The `fsharp-compute-indentation'" 276 | :var ((file (concat fsharp-struct-test-files-dir "BracketIndent.fs"))) 277 | (it "indents on the first line after opening bracket" 278 | (with-current-buffer (find-file-noselect file) 279 | (goto-char (point-min)) 280 | (search-forward-regexp "let formatTwo = \\[\n") 281 | (should (eq (fsharp-compute-indentation t) fsharp-indent-offset))))) 282 | -------------------------------------------------------------------------------- /fsharp-mode.el: -------------------------------------------------------------------------------- 1 | ;;; fsharp-mode.el --- Support for the F# programming language 2 | 3 | ;; Copyright (C) 1997 INRIA 4 | 5 | ;; Author: 1993-1997 Xavier Leroy, Jacques Garrigue and Ian T Zimmerman 6 | ;; 2010-2011 Laurent Le Brun 7 | ;; 2012-2014 Robin Neatherway 8 | ;; 2017-2023 Jürgen Hötzel 9 | ;; Maintainer: Jürgen Hötzel 10 | ;; Package-Requires: ((emacs "25")) 11 | ;; Keywords: languages 12 | ;; Version: 1.11-snapshot 13 | 14 | ;; This file is not part of GNU Emacs. 15 | 16 | ;; This file is free software; you can redistribute it and/or modify 17 | ;; it under the terms of the GNU General Public License as published by 18 | ;; the Free Software Foundation; either version 3, or (at your option) 19 | ;; any later version. 20 | 21 | ;; This file is distributed in the hope that it will be useful, 22 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 23 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 24 | ;; GNU General Public License for more details. 25 | 26 | ;; You should have received a copy of the GNU General Public License 27 | ;; along with GNU Emacs; see the file COPYING. If not, write to 28 | ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 29 | ;; Boston, MA 02110-1301, USA. 30 | 31 | ;;; Code: 32 | 33 | (require 'fsharp-mode-structure) 34 | (require 'inf-fsharp-mode) 35 | (require 'fsharp-mode-util) 36 | (require 'compile) 37 | (require 'project) 38 | (require 'subr-x) 39 | (require 'seq) 40 | 41 | (defgroup fsharp nil 42 | "Support for the Fsharp programming language, " 43 | :group 'languages 44 | :prefix "fsharp-") 45 | 46 | ;;; Compilation 47 | 48 | (defvar fsharp-compile-command 49 | (seq-some #'fsharp-mode--executable-find '("fsharpc" "fsc")) 50 | "The program used to compile F# source files.") 51 | 52 | (defvar fsharp-build-command 53 | (seq-some #'fsharp-mode--msbuild-find '("msbuild" "xbuild")) 54 | "The command used to build F# projects and solutions.") 55 | 56 | ;;; ---------------------------------------------------------------------------- 57 | 58 | (defvar fsharp-shell-active nil 59 | "Non nil when a subshell is running.") 60 | 61 | (defvar running-xemacs (string-match "XEmacs" emacs-version) 62 | "Non-nil if we are running in the XEmacs environment.") 63 | 64 | (defvar fsharp-mode-map nil 65 | "Keymap used in fsharp mode.") 66 | 67 | (unless fsharp-mode-map 68 | (setq fsharp-mode-map (make-sparse-keymap)) 69 | (if running-xemacs 70 | (define-key fsharp-mode-map 'backspace 'backward-delete-char-untabify) 71 | (define-key fsharp-mode-map "\177" 'backward-delete-char-untabify)) 72 | 73 | ;; F# bindings 74 | (define-key fsharp-mode-map "\C-c\C-a" 'fsharp-find-alternate-file) 75 | (define-key fsharp-mode-map "\C-c\C-c" 'compile) 76 | (define-key fsharp-mode-map "\M-\C-x" 'fsharp-eval-phrase) 77 | (define-key fsharp-mode-map "\C-c\C-e" 'fsharp-eval-phrase) 78 | (define-key fsharp-mode-map "\C-x\C-e" 'fsharp-eval-phrase) 79 | (define-key fsharp-mode-map "\C-c\C-r" 'fsharp-eval-region) 80 | (define-key fsharp-mode-map "\C-c\C-f" 'fsharp-load-buffer-file) 81 | (define-key fsharp-mode-map "\C-c\C-s" 'fsharp-show-subshell) 82 | (define-key fsharp-mode-map "\M-\C-h" 'fsharp-mark-phrase) 83 | 84 | (define-key fsharp-mode-map (kbd "M-n") 'next-error) 85 | (define-key fsharp-mode-map (kbd "M-p") 'previous-error) 86 | 87 | (define-key fsharp-mode-map "\C-c<" 'fsharp-shift-region-left) 88 | (define-key fsharp-mode-map "\C-c>" 'fsharp-shift-region-right) 89 | 90 | (define-key fsharp-mode-map "\C-m" 'fsharp-newline-and-indent) 91 | (define-key fsharp-mode-map "\C-c:" 'fsharp-guess-indent-offset) 92 | 93 | (define-key fsharp-mode-map (kbd "C-c ") 'fsharp-goto-block-up) 94 | 95 | (unless running-xemacs 96 | (let ((map (make-sparse-keymap "fsharp")) 97 | (forms (make-sparse-keymap "Forms"))) 98 | (define-key fsharp-mode-map [menu-bar] (make-sparse-keymap)) 99 | (define-key fsharp-mode-map [menu-bar fsharp] (cons "F#" map)) 100 | 101 | (define-key map [goto-block-up] '("Goto block up" . fsharp-goto-block-up)) 102 | (define-key map [mark-phrase] '("Mark phrase" . fsharp-mark-phrase)) 103 | (define-key map [shift-left] '("Shift region to right" . fsharp-shift-region-right)) 104 | (define-key map [shift-right] '("Shift region to left" . fsharp-shift-region-left)) 105 | (define-key map [separator-2] '("---")) 106 | 107 | ;; others 108 | (define-key map [compile] '("Compile..." . compile)) 109 | (define-key map [switch-view] '("Switch view" . fsharp-find-alternate-file)) 110 | (define-key map [separator-1] '("--")) 111 | (define-key map [show-subshell] '("Show subshell" . fsharp-show-subshell)) 112 | (define-key map [eval-region] '("Eval region" . fsharp-eval-region)) 113 | (define-key map [eval-phrase] '("Eval phrase" . fsharp-eval-phrase))))) 114 | 115 | ;;;###autoload 116 | (progn 117 | (add-to-list 'auto-mode-alist '("\\.fs[iylx]?\\'" . fsharp-mode)) 118 | (add-to-list 'auto-mode-alist '("\\.fsproj\\'" . nxml-mode))) 119 | 120 | (defvar fsharp-mode-syntax-table nil 121 | "Syntax table in use in fsharp mode buffers.") 122 | (unless fsharp-mode-syntax-table 123 | (setq fsharp-mode-syntax-table (make-syntax-table)) 124 | ; backslash is an escape sequence 125 | (modify-syntax-entry ?\\ "\\" fsharp-mode-syntax-table) 126 | 127 | ; ( is first character of comment start 128 | (modify-syntax-entry ?\( "()1n" fsharp-mode-syntax-table) 129 | ; * is second character of comment start, 130 | ; and first character of comment end 131 | (modify-syntax-entry ?* ". 23n" fsharp-mode-syntax-table) 132 | ; ) is last character of comment end 133 | (modify-syntax-entry ?\) ")(4n" fsharp-mode-syntax-table) 134 | 135 | ; // is the beginning of a comment "b" 136 | (modify-syntax-entry ?/ ". 12b" fsharp-mode-syntax-table) 137 | ; // \n is the end of a comment "b" 138 | (modify-syntax-entry ?\n "> b" fsharp-mode-syntax-table) 139 | 140 | ; quote and underscore are part of symbols 141 | ; so are # and ! as they can form part of types/preprocessor 142 | ; directives and also keywords 143 | (modify-syntax-entry ?' "_" fsharp-mode-syntax-table) 144 | (modify-syntax-entry ?_ "_" fsharp-mode-syntax-table) 145 | (modify-syntax-entry ?# "_" fsharp-mode-syntax-table) 146 | (modify-syntax-entry ?! "_" fsharp-mode-syntax-table) 147 | 148 | ; ISO-latin accented letters and EUC kanjis are part of words 149 | (let ((i 160)) 150 | (while (< i 256) 151 | (modify-syntax-entry i "w" fsharp-mode-syntax-table) 152 | (setq i (1+ i))))) 153 | 154 | ;; Other internal variables 155 | 156 | (defvar fsharp-last-noncomment-pos nil 157 | "Caches last buffer position determined not inside a fsharp comment.") 158 | (make-variable-buffer-local 'fsharp-last-noncomment-pos) 159 | 160 | ;; last-noncomment-pos can be a simple position, because we nil it 161 | ;; anyway whenever buffer changes upstream. last-comment-start and -end 162 | ;; have to be markers, because we preserve them when the changes' end 163 | ;; doesn't overlap with the comment's start. 164 | 165 | (defvar fsharp-last-comment-start nil 166 | "A marker caching last determined fsharp comment start.") 167 | (make-variable-buffer-local 'fsharp-last-comment-start) 168 | 169 | (defvar fsharp-last-comment-end nil 170 | "A marker caching last determined fsharp comment end.") 171 | (make-variable-buffer-local 'fsharp-last-comment-end) 172 | 173 | (defvar fsharp-mode-hook nil 174 | "Hook for fsharp-mode") 175 | 176 | (defcustom fsharp-autosave-on-file-load nil 177 | "Determine if buffer should be automatically saved on 178 | `fsharp-load-buffer-file'. 179 | If set to t, the buffer will always be saved, silently." 180 | :type 'boolean 181 | :group 'fsharp-mode) 182 | 183 | ;;;###autoload 184 | (define-derived-mode fsharp-mode prog-mode "fsharp" 185 | :syntax-table fsharp-mode-syntax-table 186 | "Major mode for editing fsharp code. 187 | 188 | \\{fsharp-mode-map}" 189 | 190 | (require 'fsharp-mode-font) 191 | 192 | (fsharp-mode-indent-smie-setup) 193 | 194 | (use-local-map fsharp-mode-map) 195 | 196 | (mapc 'make-local-variable 197 | '(paragraph-start 198 | require-final-newline 199 | paragraph-separate 200 | paragraph-ignore-fill-prefix 201 | comment-start 202 | comment-end 203 | comment-column 204 | comment-start-skip 205 | comment-indent-function 206 | adaptive-fill-regexp 207 | parse-sexp-ignore-comments 208 | indent-region-function 209 | indent-line-function 210 | add-log-current-defun-function 211 | underline-minimum-offset 212 | compile-command 213 | syntax-propertize-function)) 214 | 215 | (setq local-abbrev-table fsharp-mode-abbrev-table 216 | paragraph-start (concat "^$\\|" page-delimiter) 217 | paragraph-separate paragraph-start 218 | require-final-newline 'visit-save 219 | indent-tabs-mode nil 220 | comment-start "//" 221 | comment-end "" 222 | comment-column 40 223 | comment-start-skip "///* *" 224 | adaptive-fill-regexp "[ \t]*\\(//+[ \t]*\\)*" 225 | comment-indent-function 'fsharp-comment-indent-function 226 | indent-region-function 'fsharp-indent-region 227 | indent-line-function 'fsharp-indent-line 228 | underline-minimum-offset 4 229 | 230 | paragraph-ignore-fill-prefix t 231 | add-log-current-defun-function 'fsharp-current-defun 232 | fsharp-last-noncomment-pos nil 233 | fsharp-last-comment-start (make-marker) 234 | fsharp-last-comment-end (make-marker)) 235 | 236 | ; Syntax highlighting 237 | (setq font-lock-defaults '(fsharp-font-lock-keywords)) 238 | (setq syntax-propertize-function 'fsharp--syntax-propertize-function) 239 | ; Some reasonable defaults for company mode 240 | ;; In Emacs 24.4 onwards, tell electric-indent-mode that fsharp-mode 241 | ;; has no deterministic indentation. 242 | (when (boundp 'electric-indent-inhibit) (setq electric-indent-inhibit t)) 243 | 244 | (when-let ((file (buffer-file-name))) 245 | (setq compile-command (fsharp-mode-choose-compile-command file)))) 246 | 247 | (defun fsharp-mode-choose-compile-command (file) 248 | "Format an appropriate compilation command, depending on several factors: 249 | 1. The presence of a makefile 250 | 2. The presence of a .sln or .fsproj 251 | 3. The file's type. 252 | " 253 | (let* ((fname (file-name-nondirectory file)) 254 | (dname (file-name-directory file)) 255 | (ext (file-name-extension file)) 256 | (proj (fsharp-mode/find-sln-or-fsproj file)) 257 | (makefile (or (file-exists-p (concat dname "/Makefile")) 258 | (file-exists-p (concat dname "/makefile"))))) 259 | (cond 260 | (makefile compile-command) 261 | ((and fsharp-build-command proj) (combine-and-quote-strings `(,fsharp-build-command "/nologo" ,proj))) 262 | ((and fsharp-compile-command (member ext '("fs" "fsx"))) (combine-and-quote-strings `(,fsharp-compile-command "--nologo" ,file))) 263 | ((equal ext "fsl") (combine-and-quote-strings (list "fslex" file))) 264 | ((equal ext "fsy") (combine-and-quote-strings (list "fsyacc" file))) 265 | (t compile-command)))) 266 | 267 | (defun fsharp-find-alternate-file () 268 | (interactive) 269 | (let ((name (buffer-file-name))) 270 | (if (string-match "^\\(.*\\)\\.\\(fs\\|fsi\\)$" name) 271 | (find-file 272 | (concat 273 | (fsharp-match-string 1 name) 274 | (if (string= "fs" (fsharp-match-string 2 name)) ".fsi" ".fs")))))) 275 | 276 | ;;; Subshell support 277 | 278 | (defun fsharp-eval-region (start end) 279 | "Send the current region to the inferior fsharp process." 280 | (interactive"r") 281 | (require 'inf-fsharp-mode) 282 | (inferior-fsharp-eval-region start end)) 283 | 284 | (defun fsharp-eval-phrase () 285 | "Send current phrase to the interactive mode" 286 | (interactive) 287 | (save-excursion 288 | (let ((p1) (p2)) 289 | (fsharp-beginning-of-block) 290 | (setq p1 (point)) 291 | (fsharp-end-of-block) 292 | (setq p2 (point)) 293 | (fsharp-eval-region p1 p2)))) 294 | 295 | (defun fsharp-load-buffer-file () 296 | "Load the filename corresponding to the present buffer in F# with #load" 297 | (interactive) 298 | (require 'inf-fsharp-mode) 299 | (let* ((name buffer-file-name) 300 | (command (concat "#load \"" name "\""))) 301 | (when (and (buffer-modified-p) 302 | (or fsharp-autosave-on-file-load 303 | (y-or-n-p (concat "Do you want to save \"" name 304 | "\" before loading it? ")))) 305 | (save-buffer)) 306 | (fsharp-run-process-if-needed) 307 | (fsharp-simple-send inferior-fsharp-buffer-name command))) 308 | 309 | (defun fsharp-show-subshell () 310 | (interactive) 311 | (require 'inf-fsharp-mode) 312 | (inferior-fsharp-show-subshell)) 313 | 314 | (defconst fsharp-error-regexp-fs 315 | "^\\([^(\n]+\\)(\\([0-9]+\\),\\([0-9]+\\)):" 316 | "Regular expression matching the error messages produced by fsc.") 317 | 318 | (if (boundp 'compilation-error-regexp-alist) 319 | (or (memq 'fsharp 320 | compilation-error-regexp-alist) 321 | (progn 322 | (add-to-list 'compilation-error-regexp-alist 'fsharp) 323 | (add-to-list 'compilation-error-regexp-alist-alist 324 | `(fsharp ,fsharp-error-regexp-fs 1 2 3))))) 325 | 326 | ;; Usual match-string doesn't work properly with font-lock-mode 327 | ;; on some emacs. 328 | 329 | (defun fsharp-match-string (num &optional string) 330 | 331 | "Return string of text matched by last search, without properties. 332 | 333 | NUM specifies which parenthesized expression in the last regexp. 334 | Value is nil if NUMth pair didn't match, or there were less than NUM 335 | pairs. Zero means the entire text matched by the whole regexp or 336 | whole string." 337 | 338 | (let* ((data (match-data)) 339 | (begin (nth (* 2 num) data)) 340 | (end (nth (1+ (* 2 num)) data))) 341 | (if string (substring string begin end) 342 | (buffer-substring-no-properties begin end)))) 343 | 344 | ;;; Project 345 | 346 | (defun fsharp-mode/find-sln-or-fsproj (dir-or-file) 347 | "Search for a solution or F# project file in any enclosing 348 | folders relative to DIR-OR-FILE." 349 | (fsharp-mode-search-upwards (rx (0+ nonl) (or ".fsproj" ".sln") eol) 350 | (file-name-directory dir-or-file))) 351 | 352 | (defun fsharp-mode-search-upwards (regex dir) 353 | (when dir 354 | (or (car-safe (directory-files dir 'full regex)) 355 | (fsharp-mode-search-upwards regex (fsharp-mode-parent-dir dir))))) 356 | 357 | (defun fsharp-mode-parent-dir (dir) 358 | (let ((p (file-name-directory (directory-file-name dir)))) 359 | (unless (equal p dir) 360 | p))) 361 | 362 | ;; Make project.el aware of fsharp projects 363 | (defun fsharp-mode-project-root (dir) 364 | (when-let (project-file (fsharp-mode/find-sln-or-fsproj dir)) 365 | (cons 'fsharp (file-name-directory project-file)))) 366 | 367 | (cl-defmethod project-roots ((project (head fsharp))) 368 | (list (cdr project))) 369 | 370 | (add-hook 'project-find-functions #'fsharp-mode-project-root) 371 | 372 | (provide 'fsharp-mode) 373 | 374 | ;;; fsharp-mode.el ends here 375 | -------------------------------------------------------------------------------- /fsharp-mode-font.el: -------------------------------------------------------------------------------- 1 | ;;; fsharp-mode-font.el --- Syntax highlighting for F# 2 | 3 | ;; Copyright (C) 1997 INRIA 4 | 5 | ;; Author: 1993-1997 Xavier Leroy, Jacques Garrigue and Ian T Zimmerman 6 | ;; 2010-2011 Laurent Le Brun 7 | ;; Maintainer: Robin Neatherway 8 | ;; Keywords: languages 9 | 10 | ;; This file is not part of GNU Emacs. 11 | 12 | ;; This file is free software; you can redistribute it and/or modify 13 | ;; it under the terms of the GNU General Public License as published by 14 | ;; the Free Software Foundation; either version 3, or (at your option) 15 | ;; any later version. 16 | 17 | ;; This file is distributed in the hope that it will be useful, 18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 20 | ;; GNU General Public License for more details. 21 | 22 | ;; You should have received a copy of the GNU General Public License 23 | ;; along with GNU Emacs; see the file COPYING. If not, write to 24 | ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 25 | ;; Boston, MA 02110-1301, USA. 26 | 27 | ;;; Commentary: 28 | 29 | ;;; Code: 30 | 31 | (defgroup fsharp-ui nil 32 | "F# UI group for the defcustom interface." 33 | :prefix "fsharp-ui-" 34 | :group 'fsharp 35 | :package-version '(fsharp-mode . "1.9.2")) 36 | 37 | (defface fsharp-ui-generic-face 38 | '((t (:inherit default))) 39 | "Preprocessor face" 40 | :group 'fsharp-ui) 41 | 42 | (defface fsharp-ui-operator-face 43 | '((t (:foreground "LightSkyBlue"))) 44 | "Preprocessor face" 45 | :group 'fsharp-ui) 46 | 47 | (defface fsharp-ui-warning-face 48 | '((t (:inherit font-lock-warning-face))) 49 | "Face for warnings." 50 | :group 'fsharp-ui) 51 | 52 | (defface fsharp-ui-error-face 53 | '((t (:inherit font-lock-error-face :underline t))) 54 | "Face for errors" 55 | :group 'fsharp-ui) 56 | 57 | (defmacro def-fsharp-compiled-var (sym init &optional docstring) 58 | "Defines a SYMBOL as a constant inside an eval-and-compile form 59 | with initial value INITVALUE and optional DOCSTRING." 60 | `(eval-and-compile 61 | (defvar ,sym ,init ,docstring))) 62 | 63 | (def-fsharp-compiled-var fsharp-shebang-regexp 64 | "\\(^#!.*?\\)\\([A-Za-z0-9_-]+\\)$" 65 | "Capture the #! and path of a shebag in one group and the 66 | executable in another.") 67 | 68 | (def-fsharp-compiled-var fsharp-access-control-regexp 69 | "private\\s-+\\|internal\\s-+\\|public\\s-+" 70 | "Match `private', `internal', or `public', followed by a space, 71 | with no capture.") 72 | 73 | (def-fsharp-compiled-var fsharp-access-control-regexp-noncapturing 74 | (format "\\(?:%s\\)" fsharp-access-control-regexp) 75 | "Same as `fsharp-access-control-regexp', but captures") 76 | 77 | (def-fsharp-compiled-var fsharp-inline-rec-regexp 78 | "inline\\s-+\\|rec\\s-+" 79 | "Match `inline' or `rec', followed by a space.") 80 | 81 | (def-fsharp-compiled-var fsharp-inline-rec-regexp-noncapturing 82 | (format "\\(?:%s\\)" fsharp-inline-rec-regexp) 83 | "Match `inline' or `rec', followed by a space, with no capture.") 84 | 85 | (def-fsharp-compiled-var fsharp-valid-identifier-regexp 86 | "[A-Za-z0-9_']+" 87 | "Match a normal, valid F# identifier -- alphanumeric characters 88 | plus ' and underbar. Does not capture") 89 | 90 | (def-fsharp-compiled-var fsharp-function-def-regexp 91 | (concat "\\<\\(?:let\\|and\\|with\\)\\s-+" 92 | fsharp-inline-rec-regexp-noncapturing "?" 93 | fsharp-access-control-regexp-noncapturing "*" 94 | (format "\\(%s\\)" fsharp-valid-identifier-regexp) 95 | "\\(?:\\s-+[A-Za-z_]\\|\\s-*(\\)" ;; matches function arguments or open-paren; unclear why 0-9 not in class 96 | )) 97 | 98 | (def-fsharp-compiled-var fsharp-pattern-function-regexp 99 | (concat "\\<\\(?:let\\|and\\)\\s-+" 100 | fsharp-inline-rec-regexp-noncapturing "?" 101 | fsharp-access-control-regexp-noncapturing "*" 102 | (format "\\(%s\\)" fsharp-valid-identifier-regexp) 103 | "\\s-*=\\s-*function") 104 | "Matches an implicit matcher, eg let foo m = function | \"cat\" -> etc.") 105 | 106 | ;; Note that this regexp is used for iMenu. To font-lock active patterns, we 107 | ;; need to use an anchored match in fsharp-font-lock-keywords. 108 | (def-fsharp-compiled-var fsharp-active-pattern-regexp 109 | (concat "\\<\\(?:let\\|and\\)\\s-+" 110 | fsharp-inline-rec-regexp-noncapturing "?" 111 | fsharp-access-control-regexp-noncapturing "*" 112 | "(\\(|[A-Za-z0-9_'|]+|\\))\\(?:\\s-+[A-Za-z_]\\|\\s-*(\\)")) 113 | 114 | (def-fsharp-compiled-var fsharp-member-access-regexp 115 | "\\<\\(?:override\\|member\\|abstract\\)\\s-+" 116 | "Matches members declarations and modifiers on classes.") 117 | 118 | (def-fsharp-compiled-var fsharp-member-function-regexp 119 | (concat fsharp-member-access-regexp 120 | fsharp-inline-rec-regexp-noncapturing "?" 121 | fsharp-access-control-regexp-noncapturing "*" 122 | "\\(?:" fsharp-valid-identifier-regexp "\\.\\)?" 123 | "\\(" fsharp-valid-identifier-regexp "\\)") 124 | "Captures the final identifier in a member function declaration.") 125 | 126 | (def-fsharp-compiled-var fsharp-overload-operator-regexp 127 | (concat fsharp-member-access-regexp 128 | fsharp-inline-rec-regexp-noncapturing "?" 129 | fsharp-access-control-regexp-noncapturing "*" 130 | "\\(([!%&*+-./<=>?@^|~]+)\\)") 131 | "Match operators when overloaded by a type/class.") 132 | 133 | (def-fsharp-compiled-var fsharp-constructor-regexp 134 | (concat "^\\s-*" 135 | fsharp-access-control-regexp-noncapturing "*" 136 | "\\<\\(new\\) *(.*)[^=]*=") 137 | "Matches the `new' keyword in a constructor") 138 | 139 | (def-fsharp-compiled-var fsharp-type-def-regexp 140 | (concat "^\\s-*\\<\\(?:type\\|inherit\\)\\s-+" 141 | fsharp-access-control-regexp-noncapturing "*" ;; match access control 0 or more times 142 | "\\([A-Za-z0-9_'.]+\\)")) 143 | 144 | (def-fsharp-compiled-var fsharp-var-or-arg-regexp 145 | "\\_<\\([A-Za-z_][A-Za-z0-9_']*\\)\\_>") 146 | 147 | (def-fsharp-compiled-var fsharp-explicit-field-regexp 148 | (concat "^\\s-*\\(?:val\\|abstract\\)\\s-*\\(?:mutable\\s-+\\)?" 149 | fsharp-access-control-regexp-noncapturing "*" ;; match access control 0 or more times 150 | "\\([A-Za-z_][A-Za-z0-9_']*\\)\\s-*:\\s-*\\([A-Za-z_][A-Za-z0-9_'<> \t]*\\)")) 151 | 152 | (def-fsharp-compiled-var fsharp-attributes-regexp 153 | "\\(\\[<[A-Za-z0-9_]+[( ]?\\)\\(\".*\"\\)?\\()?>\\]\\)" 154 | "Match attributes like []; separately groups contained strings in attributes like []") 155 | 156 | ;; F# makes extensive use of operators, many of which have some kind of 157 | ;; structural significance. 158 | ;; 159 | ;; In particular: 160 | ;; (| ... |) -- banana clips for Active Patterns (handled separately) 161 | ;; <@ ... @> and <@@ ... @@> -- quoted expressions 162 | ;; <| and |> -- left and right pipe (also <||, <|||, ||>, |||>) 163 | ;; << and >> -- function composition 164 | ;; | -- match / type expressions 165 | 166 | (def-fsharp-compiled-var fsharp-operator-quote-regexp 167 | "\\(<@\\{1,2\\}\\)\\(?:.*\\)\\(@\\{1,2\\}>\\)" 168 | "Font lock <@/<@@ and @>/@@> operators.") 169 | 170 | (def-fsharp-compiled-var fsharp-operator-pipe-regexp 171 | "<|\\{1,3\\}\\||\\{1,3\\}>" 172 | "Match the full range of pipe operators -- |>, ||>, |||>, etc.") 173 | 174 | (def-fsharp-compiled-var fsharp-custom-operator-with-pipe-regexp 175 | (let ((op-chars "!%&\\*\\+\\-\\./<=>@\\^~") ;; all F# custom operator chars except for `|` 176 | (backward-pipe "<|\\{1,3\\}") 177 | (forward-pipe "|\\{1,3\\}>") 178 | (alt "\\|")) 179 | (concat "[" op-chars "|]*" backward-pipe "[" op-chars "]+" 180 | alt "[" op-chars "|]+" backward-pipe "[" op-chars "]*" 181 | alt "[" op-chars "]*" forward-pipe "[" op-chars "|]+" 182 | alt "[" op-chars "]+" forward-pipe "[" op-chars "|]*")) 183 | "Match operators that contains pipe sequence -- <|>, |>>, <<|, etc.") 184 | 185 | (def-fsharp-compiled-var fsharp-operator-case-regexp 186 | "\\s-+\\(|\\)[A-Za-z0-9_' ]" 187 | "Match literal | in contexts like match and type declarations.") 188 | 189 | (defvar fsharp-imenu-generic-expression 190 | `((nil ,(concat "^\\s-*" fsharp-function-def-regexp) 1) 191 | (nil ,(concat "^\\s-*" fsharp-pattern-function-regexp) 1) 192 | ("Active Pattern" ,(concat "^\\s-*" fsharp-active-pattern-regexp) 1) 193 | ("Member" ,(concat "^\\s-*" fsharp-member-function-regexp) 1) 194 | ("Overload Operator" ,(concat "^\\s-*" fsharp-overload-operator-regexp) 1) 195 | ("Constructor" ,fsharp-constructor-regexp 1) 196 | ("Type" ,fsharp-type-def-regexp 1) 197 | ("Module" ,(concat "\\s-*module " fsharp-var-or-arg-regexp) 1)) 198 | 199 | "Provide iMenu support through font-locking regexen.") 200 | 201 | (defun fsharp-imenu-load-index () 202 | "Hook up the provided regexen to enable imenu support." 203 | (setq imenu-generic-expression fsharp-imenu-generic-expression)) 204 | 205 | (add-hook 'fsharp-mode-hook #'fsharp-imenu-load-index) 206 | 207 | (defun fsharp-var-pre-form () 208 | (save-excursion 209 | (re-search-forward "\\(:\\s-*\\w[^)]*\\)?=" nil t) 210 | (match-beginning 0))) 211 | 212 | (defun fsharp-fun-pre-form () 213 | (save-excursion 214 | (search-forward "->"))) 215 | 216 | ;; Preprocessor directives (3.3) 217 | (def-fsharp-compiled-var fsharp-ui-preproessor-directives 218 | '("#if" "#else" "#endif" "#light")) 219 | 220 | ;; Compiler directives (12.4) 221 | (def-fsharp-compiled-var fsharp-ui-compiler-directives 222 | '("#nowarn" "#load" "#r" "#reference" "#I" 223 | "#Include" "#q" "#quit" "#time" "#help")) 224 | 225 | ;; Lexical matters (18.4) 226 | (def-fsharp-compiled-var fsharp-ui-lexical-matters 227 | '("#indent")) 228 | 229 | ;; Line Directives (3.9) 230 | (def-fsharp-compiled-var fsharp-ui-line-directives 231 | '("#line")) 232 | 233 | ;; Identifier replacements (3.11) 234 | (def-fsharp-compiled-var fsharp-ui-identifier-replacements 235 | '("__SOURCE_DIRECTORY__" "__SOURCE_FILE__" "__LINE__")) 236 | 237 | ;; F# keywords (5.0) 238 | (def-fsharp-compiled-var fsharp-ui-fsharp-threefour-keywords 239 | '("abstract" "and" "and!" "as" "assert" "base" "begin" 240 | "class" "default" "delegate" "do" "do!" "done" 241 | "downcast" "downto" "elif" "else" "end" 242 | "exception" "extern" "false" "finally" "for" "fun" 243 | "function" "global" "if" "in" "inherit" "inline" 244 | "interface" "internal" "lazy" "let" "let!" 245 | "match" "match!" "member" "module" "mutable" "namespace" 246 | "new" "not" "null" "of" "open" "or" "override" 247 | "private" "public" "rec" "return" "return!" 248 | "select" "static" "struct" "then" "to" "true" 249 | "try" "type" "upcast" "use" "use!" "val" "void" 250 | "when" "while" "with" "yield" "yield!")) 251 | 252 | ;; "Reserved because they are reserved in OCaml" 253 | (def-fsharp-compiled-var fsharp-ui-ocaml-reserved-words 254 | '("asr" "land" "lor" "lsl" "lsr" "lxor" "mod" "sig")) 255 | 256 | ;; F# reserved words for future use 257 | (def-fsharp-compiled-var fsharp-ui-reserved-words 258 | '("atomic" "break" "checked" "component" "const" 259 | "constraint" "constructor" "continue" "eager" 260 | "event" "external" "fixed" "functor" "include" 261 | "method" "mixin" "object" "parallel" "process" 262 | "protected" "pure" "sealed" "tailcall" "trait" 263 | "virtual" "volatile")) 264 | 265 | ;; RMD 2016-09-30 -- This was pulled out separately with the following comment 266 | ;; when I got here. Not clear to me why it's on it's own, or even precisely what 267 | ;; the comment means. But: `async' is a valid F# keyword and needs to go someplace, 268 | ;; so I've left it here. For now. 269 | ;; 270 | ;; Workflows not yet handled by fsautocomplete but async 271 | ;; always present 272 | (def-fsharp-compiled-var fsharp-ui-async-words 273 | '("async") 274 | "Just the word async, in a list.") 275 | 276 | (def-fsharp-compiled-var fsharp-ui-word-list-regexp 277 | (regexp-opt 278 | `(,@fsharp-ui-async-words 279 | ,@fsharp-ui-compiler-directives 280 | ,@fsharp-ui-fsharp-threefour-keywords 281 | ,@fsharp-ui-identifier-replacements 282 | ,@fsharp-ui-lexical-matters 283 | ,@fsharp-ui-ocaml-reserved-words 284 | ,@fsharp-ui-preproessor-directives 285 | ,@fsharp-ui-reserved-words 286 | ,@fsharp-ui-line-directives) 287 | 'symbols)) 288 | 289 | (defconst fsharp-font-lock-keywords 290 | (eval-when-compile 291 | `((,fsharp-ui-word-list-regexp 0 font-lock-keyword-face) 292 | ;; shebang 293 | (,fsharp-shebang-regexp 294 | (1 font-lock-comment-face) 295 | (2 font-lock-keyword-face)) 296 | ;; attributes 297 | (,fsharp-attributes-regexp 298 | (1 font-lock-preprocessor-face) 299 | (2 font-lock-string-face nil t) 300 | (3 font-lock-preprocessor-face)) 301 | ;; ;; type defines 302 | (,fsharp-type-def-regexp 1 font-lock-type-face) 303 | (,fsharp-function-def-regexp 1 font-lock-function-name-face) 304 | (,fsharp-pattern-function-regexp 1 font-lock-function-name-face) 305 | ;; Active Pattern 306 | ("(|" (0 'fsharp-ui-operator-face) 307 | ("\\([A-Za-z'_]+\\)\\(|)?\\)" 308 | nil nil 309 | (1 font-lock-function-name-face) 310 | (2 'fsharp-ui-operator-face))) 311 | (,fsharp-custom-operator-with-pipe-regexp . 'fsharp-ui-generic-face) 312 | (,fsharp-operator-pipe-regexp . 'fsharp-ui-operator-face) 313 | (,fsharp-member-function-regexp 1 font-lock-function-name-face) 314 | (,fsharp-overload-operator-regexp 1 font-lock-function-name-face) 315 | (,fsharp-constructor-regexp 1 font-lock-function-name-face) 316 | (,fsharp-operator-case-regexp 1 'fsharp-ui-operator-face) 317 | (,fsharp-operator-quote-regexp (1 'fsharp-ui-operator-face) 318 | (2 'fsharp-ui-operator-face)) 319 | ("[^:]:\\s-*\\(\\<[A-Za-z0-9_' ]*[^ ;\n,)}=<-]\\)\\(<[^>]*>\\)?" 320 | (1 font-lock-type-face) 321 | ;; 'prevent generic type arguments from being rendered in variable face 322 | (2 'fsharp-ui-generic-face nil t)) 323 | (,(format "^\\s-*\\<\\(let\\|use\\|override\\|member\\|and\\|\\(?:%snew\\)\\)\\_>" 324 | (concat fsharp-access-control-regexp "*")) 325 | (0 font-lock-keyword-face) ; let binding and function arguments 326 | (,fsharp-var-or-arg-regexp 327 | (fsharp-var-pre-form) nil 328 | (1 font-lock-variable-name-face nil t))) 329 | ("\\" 330 | (0 font-lock-keyword-face) ; lambda function arguments 331 | (,fsharp-var-or-arg-regexp 332 | (fsharp-fun-pre-form) nil 333 | (1 font-lock-variable-name-face nil t))) 334 | (,fsharp-type-def-regexp 335 | (0 'font-lock-keyword-face) ; implicit constructor arguments 336 | (,fsharp-var-or-arg-regexp 337 | (fsharp-var-pre-form) nil 338 | (1 font-lock-variable-name-face nil t))) 339 | (,fsharp-explicit-field-regexp 340 | (1 font-lock-variable-name-face) 341 | (2 font-lock-type-face)) 342 | 343 | ;; open namespace 344 | ("\\@^|~?]*[\n\t\r\b\a\f\v ]*\)" (1 "()")) ; symbolic operator starting (* is not a comment 367 | ("\\(/\\)\\*" (1 "."))) 368 | start end)) 369 | 370 | (defun fsharp--syntax-string (end) 371 | (let* ((pst (syntax-ppss)) 372 | (instr (nth 3 pst)) 373 | (start (nth 8 pst))) 374 | (when (eq t instr) ; Then we are in a custom string 375 | (cond 376 | ((eq ?@ (char-after start)) ; Then we are in a verbatim string 377 | (while 378 | (when (re-search-forward "\"\"?" end 'move) 379 | (if (> (- (match-end 0) (match-beginning 0)) 1) 380 | t ;; Skip this "" and keep looking further. 381 | (put-text-property (- (match-beginning 0) 1) (- (match-end 0) 1) 382 | 'syntax-table (string-to-syntax ".")) 383 | (put-text-property (match-beginning 0) (match-end 0) 384 | 'syntax-table (string-to-syntax "|")) 385 | nil)))) 386 | 387 | (t ; Then we are in a triple-quoted string 388 | (when (re-search-forward "\"\"\"" end 'move) 389 | (put-text-property (- (match-beginning 0) 1) (match-beginning 0) 390 | 'syntax-table (string-to-syntax ".")) 391 | (put-text-property (match-beginning 0) (match-end 0) 392 | 'syntax-table (string-to-syntax "|")))))))) 393 | 394 | (provide 'fsharp-mode-font) 395 | 396 | ;;; fsharp-mode-font.el ends here 397 | -------------------------------------------------------------------------------- /test/apps/FSharp.Compatibility/Format.fs: -------------------------------------------------------------------------------- 1 | (* OCaml Compatibility Library for F# (Format module) 2 | (FSharp.Compatibility.OCaml.Format) 3 | 4 | Copyright (c) 1996 Institut National de Recherche en 5 | Informatique et en Automatique 6 | Copyright (c) Jack Pappas 2012 7 | http://github.com/jack-pappas 8 | 9 | This code is distributed under the terms of the 10 | GNU Lesser General Public License (LGPL) v2.1. 11 | See the LICENSE file for details. *) 12 | 13 | // References: 14 | // http://caml.inria.fr/pub/docs/manual-ocaml/libref/Format.html 15 | 16 | /// Pretty printing. 17 | [] 18 | module FSharp.Compatibility.OCaml.Format 19 | 20 | (************************************************************** 21 | 22 | Data structures definitions. 23 | 24 | **************************************************************) 25 | // TODO : Recreate 'size' as a measure type on int 26 | type size = int 27 | let inline size_of_int (n : int) : size = n 28 | let inline int_of_size (s : size) : int = s 29 | 30 | (* Tokens are one of the following : *) 31 | type pp_token = 32 | (* normal text *) 33 | | Pp_text of string 34 | (* complete break *) 35 | | Pp_break of int * int 36 | (* go to next tabulation *) 37 | | Pp_tbreak of int * int 38 | (* set a tabulation *) 39 | | Pp_stab 40 | (* beginning of a block *) 41 | | Pp_begin of int * block_type 42 | (* end of a block *) 43 | | Pp_end 44 | (* beginning of a tabulation block *) 45 | | Pp_tbegin of tblock 46 | (* end of a tabulation block *) 47 | | Pp_tend 48 | (* to force a newline inside a block *) 49 | | Pp_newline 50 | (* to do something only if this very line has been broken *) 51 | | Pp_if_newline 52 | (* opening a tag name *) 53 | | Pp_open_tag of tag 54 | (* closing the most recently opened tag *) 55 | | Pp_close_tag 56 | 57 | and tag = string 58 | 59 | and block_type = 60 | (* Horizontal block no line breaking *) 61 | | Pp_hbox 62 | (* Vertical block each break leads to a new line *) 63 | | Pp_vbox 64 | (* Horizontal-vertical block: same as vbox, except if this block 65 | is small enough to fit on a single line *) 66 | | Pp_hvbox 67 | (* Horizontal or Vertical block: breaks lead to new line 68 | only when necessary to print the content of the block *) 69 | | Pp_hovbox 70 | (* Horizontal or Indent block: breaks lead to new line 71 | only when necessary to print the content of the block, or 72 | when it leads to a new indentation of the current line *) 73 | | Pp_box 74 | (* Internal usage: when a block fits on a single line *) 75 | | Pp_fits 76 | 77 | and tblock = 78 | (* Tabulation box *) 79 | | Pp_tbox of (int list) ref 80 | 81 | (* The Queue: 82 | contains all formatting elements. 83 | elements are tuples (size, token, length), where 84 | size is set when the size of the block is known 85 | len is the declared length of the token. *) 86 | type pp_queue_elem = { 87 | mutable elem_size : size; 88 | token : pp_token; 89 | length : int; 90 | } 91 | 92 | (* Scan stack: 93 | each element is (left_total, queue element) where left_total 94 | is the value of pp_left_total when the element has been enqueued. *) 95 | type pp_scan_elem = 96 | | Scan_elem of int * pp_queue_elem 97 | 98 | (* Formatting stack: 99 | used to break the lines while printing tokens. 100 | The formatting stack contains the description of 101 | the currently active blocks. *) 102 | type pp_format_elem = 103 | | Format_elem of block_type * int 104 | 105 | (* General purpose queues, used in the formatter. *) 106 | type 'a queue_elem = 107 | | Nil 108 | | Cons of 'a queue_cell 109 | 110 | and 'a queue_cell = { 111 | mutable head : 'a; 112 | mutable tail : 'a queue_elem; 113 | } 114 | 115 | type 'a queue = { 116 | mutable insert : 'a queue_elem; 117 | mutable body : 'a queue_elem; 118 | } 119 | 120 | (* The formatter specific tag handling functions. *) 121 | type formatter_tag_functions = { 122 | mark_open_tag : tag -> string; 123 | mark_close_tag : tag -> string; 124 | print_open_tag : tag -> unit; 125 | print_close_tag : tag -> unit; 126 | } 127 | 128 | (* A formatter with all its machinery. *) 129 | type formatter = { 130 | mutable pp_scan_stack : pp_scan_elem list; 131 | mutable pp_format_stack : pp_format_elem list; 132 | mutable pp_tbox_stack : tblock list; 133 | mutable pp_tag_stack : tag list; 134 | mutable pp_mark_stack : tag list; 135 | (* Global variables: default initialization is 136 | set_margin 78 137 | set_min_space_left 0. *) 138 | /// Value of right margin. 139 | mutable pp_margin : int; 140 | /// Minimal space left before margin, when opening a block. 141 | mutable pp_min_space_left : int; 142 | /// Maximum value of indentation: no blocks can be opened further. 143 | mutable pp_max_indent : int; 144 | /// Space remaining on the current line. 145 | mutable pp_space_left : int; 146 | /// Current value of indentation. 147 | mutable pp_current_indent : int; 148 | /// True when the line has been broken by the pretty-printer. 149 | mutable pp_is_new_line : bool; 150 | /// Total width of tokens already printed. 151 | mutable pp_left_total : int; 152 | /// Total width of tokens ever put in queue. 153 | mutable pp_right_total : int; 154 | /// Current number of opened blocks. 155 | mutable pp_curr_depth : int; 156 | /// Maximum number of blocks which can be simultaneously opened. 157 | mutable pp_max_boxes : int; 158 | /// Ellipsis string. 159 | mutable pp_ellipsis : string; 160 | /// Output function. 161 | mutable pp_out_string : string -> int -> int -> unit; 162 | /// Flushing function. 163 | mutable pp_out_flush : unit -> unit; 164 | /// Output of new lines. 165 | mutable pp_out_newline : unit -> unit; 166 | /// Output of indentation spaces. 167 | mutable pp_out_spaces : int -> unit; 168 | /// Are tags printed? 169 | mutable pp_print_tags : bool; 170 | /// Are tags marked? 171 | mutable pp_mark_tags : bool; 172 | /// Find opening and closing markers of tags. 173 | mutable pp_mark_open_tag : tag -> string; 174 | mutable pp_mark_close_tag : tag -> string; 175 | mutable pp_print_open_tag : tag -> unit; 176 | mutable pp_print_close_tag : tag -> unit; 177 | /// The pretty-printer queue. 178 | mutable pp_queue : pp_queue_elem queue 179 | } 180 | 181 | (************************************************************** 182 | 183 | Auxilliaries and basic functions. 184 | 185 | **************************************************************) 186 | /// Queues auxilliaries. 187 | let make_queue () = { insert = Nil; body = Nil; } 188 | 189 | let clear_queue q = 190 | q.insert <- Nil 191 | q.body <- Nil 192 | 193 | let add_queue x q = 194 | let c = Cons { head = x; tail = Nil; } 195 | match q with 196 | | { insert = Cons cell; body = _ } -> 197 | (q.insert <- c; cell.tail <- c) 198 | | (* Invariant: when insert is Nil body should be Nil. *) 199 | { insert = Nil; body = _ } -> (q.insert <- c; q.body <- c) 200 | 201 | exception Empty_queue 202 | 203 | let peek_queue = 204 | function 205 | | { body = Cons { head = x; tail = _ }; insert = _ } -> x 206 | | { body = Nil; insert = _ } -> raise Empty_queue 207 | 208 | let take_queue = 209 | function 210 | | ({ body = Cons { head = x; tail = tl }; insert = _ } as q) -> 211 | (q.body <- tl; 212 | if tl = Nil then q.insert <- Nil else (); 213 | (* Maintain the invariant. *) 214 | x) 215 | | { body = Nil; insert = _ } -> raise Empty_queue 216 | 217 | (* Enter a token in the pretty-printer queue. *) 218 | let pp_enqueue state (({ length = len; elem_size = _; token = _ } as token)) = 219 | state.pp_right_total <- state.pp_right_total + len 220 | add_queue token state.pp_queue 221 | 222 | let pp_clear_queue state = 223 | state.pp_left_total <- 1 224 | state.pp_right_total <- 1 225 | clear_queue state.pp_queue 226 | 227 | (* Pp_infinity: large value for default tokens size. 228 | 229 | Pp_infinity is documented as being greater than 1e10; to avoid 230 | confusion about the word ``greater'', we choose pp_infinity greater 231 | than 1e10 + 1; for correct handling of tests in the algorithm, 232 | pp_infinity must be even one more than 1e10 + 1; let's stand on the 233 | safe side by choosing 1.e10+10. 234 | 235 | Pp_infinity could probably be 1073741823 that is 2^30 - 1, that is 236 | the minimal upper bound for integers; now that max_int is defined, 237 | this limit could also be defined as max_int - 1. 238 | 239 | However, before setting pp_infinity to something around max_int, we 240 | must carefully double-check all the integer arithmetic operations 241 | that involve pp_infinity, since any overflow would wreck havoc the 242 | pretty-printing algorithm's invariants. Given that this arithmetic 243 | correctness check is difficult and error prone and given that 1e10 244 | + 1 is in practice large enough, there is no need to attempt to set 245 | pp_infinity to the theoretically maximum limit. It is not worth the 246 | burden ! *) 247 | let pp_infinity = 1000000010 248 | 249 | (* Output functions for the formatter. *) 250 | let rec pp_output_string state s = state.pp_out_string s 0 (String.length s) 251 | and pp_output_newline state = state.pp_out_newline () 252 | and pp_output_spaces state n = state.pp_out_spaces n 253 | 254 | (* To format a break, indenting a new line. *) 255 | let break_new_line state offset width = 256 | (pp_output_newline state; 257 | state.pp_is_new_line <- true; 258 | let indent = (state.pp_margin - width) + offset in 259 | (* Don't indent more than pp_max_indent. *) 260 | let real_indent = min state.pp_max_indent indent 261 | in 262 | (state.pp_current_indent <- real_indent; 263 | state.pp_space_left <- state.pp_margin - state.pp_current_indent; 264 | pp_output_spaces state state.pp_current_indent)) 265 | 266 | (* To force a line break inside a block: no offset is added. *) 267 | let break_line state width = break_new_line state 0 width 268 | 269 | (* To format a break that fits on the current line. *) 270 | let break_same_line state width = 271 | (state.pp_space_left <- state.pp_space_left - width; 272 | pp_output_spaces state width) 273 | 274 | (* To indent no more than pp_max_indent, if one tries to open a block 275 | beyond pp_max_indent, then the block is rejected on the left 276 | by simulating a break. *) 277 | let pp_force_break_line state = 278 | match state.pp_format_stack with 279 | | Format_elem (bl_ty, width) :: _ -> 280 | if width > state.pp_space_left 281 | then 282 | (match bl_ty with 283 | | Pp_fits -> () 284 | | Pp_hbox -> () 285 | | Pp_vbox | Pp_hvbox | Pp_hovbox | Pp_box -> break_line state width) 286 | else () 287 | | [] -> pp_output_newline state 288 | 289 | (* To skip a token, if the previous line has been broken. *) 290 | let pp_skip_token state = 291 | (* When calling pp_skip_token the queue cannot be empty. *) 292 | match take_queue state.pp_queue with 293 | | { elem_size = size; length = len; token = _ } -> 294 | (state.pp_left_total <- state.pp_left_total - len; 295 | state.pp_space_left <- state.pp_space_left + (int_of_size size)) 296 | 297 | (************************************************************** 298 | 299 | The main pretty printing functions. 300 | 301 | **************************************************************) 302 | (* To format a token. *) 303 | let format_pp_token state size = 304 | function 305 | | Pp_text s -> 306 | (state.pp_space_left <- state.pp_space_left - size; 307 | pp_output_string state s; 308 | state.pp_is_new_line <- false) 309 | | Pp_begin (off, ty) -> 310 | let insertion_point = state.pp_margin - state.pp_space_left 311 | in 312 | (if insertion_point > state.pp_max_indent 313 | then (* can't open a block right there. *) pp_force_break_line state 314 | else (); 315 | let offset = state.pp_space_left - off in 316 | let bl_type = 317 | (match ty with 318 | | Pp_vbox -> Pp_vbox 319 | | Pp_hbox | Pp_hvbox | Pp_hovbox | Pp_box | Pp_fits -> 320 | if size > state.pp_space_left then ty else Pp_fits) 321 | in 322 | state.pp_format_stack <- 323 | (Format_elem (bl_type, offset)) :: state.pp_format_stack) 324 | | Pp_end -> 325 | (match state.pp_format_stack with 326 | | _ :: ls -> state.pp_format_stack <- ls 327 | | [] -> ()) 328 | | (* No more block to close. *) Pp_tbegin ((Pp_tbox _ as tbox)) -> 329 | state.pp_tbox_stack <- tbox :: state.pp_tbox_stack 330 | | Pp_tend -> 331 | (match state.pp_tbox_stack with 332 | | _ :: ls -> state.pp_tbox_stack <- ls 333 | | [] -> ()) 334 | | (* No more tabulation block to close. *) Pp_stab -> 335 | (match state.pp_tbox_stack with 336 | | Pp_tbox tabs :: _ -> 337 | let rec add_tab n = 338 | (function 339 | | [] -> [ n ] 340 | | (x :: l as ls) -> 341 | if n < x then n :: ls else x :: (add_tab n l)) 342 | in tabs := add_tab (state.pp_margin - state.pp_space_left) !tabs 343 | | [] -> ()) 344 | | (* No opened tabulation block. *) Pp_tbreak (n, off) -> 345 | let insertion_point = state.pp_margin - state.pp_space_left 346 | in 347 | (match state.pp_tbox_stack with 348 | | Pp_tbox tabs :: _ -> 349 | let rec find n = 350 | (function 351 | | x :: l -> if x >= n then x else find n l 352 | | [] -> raise Not_found) in 353 | let tab = 354 | (match !tabs with 355 | | x :: _ -> 356 | (try find insertion_point !tabs with | Not_found -> x) 357 | | _ -> insertion_point) in 358 | let offset = tab - insertion_point 359 | in 360 | if offset >= 0 361 | then break_same_line state (offset + n) 362 | else break_new_line state (tab + off) state.pp_margin 363 | | [] -> ()) 364 | | (* No opened tabulation block. *) Pp_newline -> 365 | (match state.pp_format_stack with 366 | | Format_elem (_, width) :: _ -> break_line state width 367 | | [] -> pp_output_newline state) 368 | | (* No opened block. *) Pp_if_newline -> 369 | if state.pp_current_indent <> (state.pp_margin - state.pp_space_left) 370 | then pp_skip_token state 371 | | Pp_break (n, off) -> 372 | (match state.pp_format_stack with 373 | | Format_elem (ty, width) :: _ -> 374 | (match ty with 375 | | Pp_hovbox -> 376 | if size > state.pp_space_left 377 | then break_new_line state off width 378 | else break_same_line state n 379 | | Pp_box -> (* Have the line just been broken here ? *) 380 | if state.pp_is_new_line 381 | then break_same_line state n 382 | else 383 | if size > state.pp_space_left 384 | then break_new_line state off width 385 | else (* break the line here leads to new indentation ? *) 386 | if 387 | state.pp_current_indent > 388 | ((state.pp_margin - width) + off) 389 | then break_new_line state off width 390 | else break_same_line state n 391 | | Pp_hvbox -> break_new_line state off width 392 | | Pp_fits -> break_same_line state n 393 | | Pp_vbox -> break_new_line state off width 394 | | Pp_hbox -> break_same_line state n) 395 | | [] -> ()) 396 | | (* No opened block. *) Pp_open_tag tag_name -> 397 | let marker = state.pp_mark_open_tag tag_name 398 | in 399 | (pp_output_string state marker; 400 | state.pp_mark_stack <- tag_name :: state.pp_mark_stack) 401 | | Pp_close_tag -> 402 | (match state.pp_mark_stack with 403 | | tag_name :: tags -> 404 | let marker = state.pp_mark_close_tag tag_name 405 | in (pp_output_string state marker; state.pp_mark_stack <- tags) 406 | | [] -> ()) 407 | 408 | (* No more tag to close. *) 409 | (* Print if token size is known or printing is delayed. 410 | Size is known when not negative. 411 | Printing is delayed when the text waiting in the queue requires 412 | more room to format than exists on the current line. 413 | 414 | Note: [advance_loop] must be tail recursive to prevent stack overflows. *) 415 | let rec advance_loop state = 416 | match peek_queue state.pp_queue with 417 | | { elem_size = size; token = tok; length = len } -> 418 | let size = int_of_size size 419 | in 420 | if 421 | not 422 | ((size < 0) && 423 | ((state.pp_right_total - state.pp_left_total) < 424 | state.pp_space_left)) 425 | then 426 | (ignore (take_queue state.pp_queue); 427 | format_pp_token state (if size < 0 then pp_infinity else size) tok; 428 | state.pp_left_total <- len + state.pp_left_total; 429 | advance_loop state) 430 | else () 431 | 432 | let advance_left state = try advance_loop state with | Empty_queue -> () 433 | 434 | let enqueue_advance state tok = (pp_enqueue state tok; advance_left state) 435 | 436 | (* To enqueue a string : try to advance. *) 437 | let make_queue_elem size tok len = 438 | { elem_size = size; token = tok; length = len; } 439 | 440 | let enqueue_string_as state size s = 441 | let len = int_of_size size 442 | in enqueue_advance state (make_queue_elem size (Pp_text s) len) 443 | 444 | let enqueue_string state s = 445 | let len = String.length s in enqueue_string_as state (size_of_int len) s 446 | 447 | (* Routines for scan stack 448 | determine sizes of blocks. *) 449 | (* The scan_stack is never empty. *) 450 | let scan_stack_bottom = 451 | let q_elem = make_queue_elem (size_of_int (-1)) (Pp_text "") 0 452 | in [ Scan_elem ((-1), q_elem) ] 453 | 454 | (* Set size of blocks on scan stack: 455 | if ty = true then size of break is set else size of block is set; 456 | in each case pp_scan_stack is popped. *) 457 | let clear_scan_stack state = state.pp_scan_stack <- scan_stack_bottom 458 | 459 | (* Pattern matching on scan stack is exhaustive, 460 | since scan_stack is never empty. 461 | Pattern matching on token in scan stack is also exhaustive, 462 | since scan_push is used on breaks and opening of boxes. *) 463 | let set_size state ty = 464 | match state.pp_scan_stack with 465 | | Scan_elem (left_tot, 466 | (({ elem_size = size; token = tok; length = _ } as queue_elem))) :: t 467 | -> 468 | let size = int_of_size size 469 | in 470 | (* test if scan stack contains any data that is not obsolete. *) 471 | if left_tot < state.pp_left_total 472 | then clear_scan_stack state 473 | else 474 | (match tok with 475 | | Pp_break (_, _) | Pp_tbreak (_, _) -> 476 | if ty 477 | then 478 | (queue_elem.elem_size <- 479 | size_of_int (state.pp_right_total + size); 480 | state.pp_scan_stack <- t) 481 | else () 482 | | Pp_begin (_, _) -> 483 | if not ty 484 | then 485 | (queue_elem.elem_size <- 486 | size_of_int (state.pp_right_total + size); 487 | state.pp_scan_stack <- t) 488 | else () 489 | | Pp_text _ | Pp_stab | Pp_tbegin _ | Pp_tend | Pp_end | 490 | Pp_newline | Pp_if_newline | Pp_open_tag _ | Pp_close_tag -> 491 | ()) 492 | | (* scan_push is only used for breaks and boxes. *) [] -> () 493 | 494 | (* scan_stack is never empty. *) 495 | (* Push a token on scan stack. If b is true set_size is called. *) 496 | let scan_push state b tok = 497 | (pp_enqueue state tok; 498 | if b then set_size state true else (); 499 | state.pp_scan_stack <- 500 | (Scan_elem (state.pp_right_total, tok)) :: state.pp_scan_stack) 501 | 502 | (* To open a new block : 503 | the user may set the depth bound pp_max_boxes 504 | any text nested deeper is printed as the ellipsis string. *) 505 | let pp_open_box_gen state indent br_ty = 506 | (state.pp_curr_depth <- state.pp_curr_depth + 1; 507 | if state.pp_curr_depth < state.pp_max_boxes 508 | then 509 | (let elem = 510 | make_queue_elem (size_of_int (- state.pp_right_total)) 511 | (Pp_begin (indent, br_ty)) 0 512 | in scan_push state false elem) 513 | else 514 | if state.pp_curr_depth = state.pp_max_boxes 515 | then enqueue_string state state.pp_ellipsis 516 | else ()) 517 | 518 | (* The box which is always opened. *) 519 | let pp_open_sys_box state = pp_open_box_gen state 0 Pp_hovbox 520 | 521 | (* Close a block, setting sizes of its sub blocks. *) 522 | let pp_close_box state () = 523 | if state.pp_curr_depth > 1 524 | then 525 | (if state.pp_curr_depth < state.pp_max_boxes 526 | then 527 | (pp_enqueue state 528 | { elem_size = size_of_int 0; token = Pp_end; length = 0; }; 529 | set_size state true; 530 | set_size state false) 531 | else (); 532 | state.pp_curr_depth <- state.pp_curr_depth - 1) 533 | else () 534 | 535 | (* Open a tag, pushing it on the tag stack. *) 536 | let pp_open_tag state tag_name = 537 | (if state.pp_print_tags 538 | then 539 | (state.pp_tag_stack <- tag_name :: state.pp_tag_stack; 540 | state.pp_print_open_tag tag_name) 541 | else (); 542 | if state.pp_mark_tags 543 | then 544 | pp_enqueue state 545 | { elem_size = size_of_int 0; token = Pp_open_tag tag_name; length = 0; 546 | } 547 | else ()) 548 | 549 | (* Close a tag, popping it from the tag stack. *) 550 | let pp_close_tag state () = 551 | (if state.pp_mark_tags 552 | then 553 | pp_enqueue state 554 | { elem_size = size_of_int 0; token = Pp_close_tag; length = 0; } 555 | else (); 556 | if state.pp_print_tags 557 | then 558 | (match state.pp_tag_stack with 559 | | tag_name :: tags -> 560 | (state.pp_print_close_tag tag_name; state.pp_tag_stack <- tags) 561 | | _ -> ()) 562 | else ()) 563 | 564 | (* No more tag to close. *) 565 | let pp_set_print_tags state b = state.pp_print_tags <- b 566 | 567 | let pp_set_mark_tags state b = state.pp_mark_tags <- b 568 | 569 | let pp_get_print_tags state () = state.pp_print_tags 570 | 571 | let pp_get_mark_tags state () = state.pp_mark_tags 572 | 573 | let pp_set_tags state b = 574 | (pp_set_print_tags state b; pp_set_mark_tags state b) 575 | 576 | let pp_get_formatter_tag_functions state () = 577 | { 578 | mark_open_tag = state.pp_mark_open_tag; 579 | mark_close_tag = state.pp_mark_close_tag; 580 | print_open_tag = state.pp_print_open_tag; 581 | print_close_tag = state.pp_print_close_tag; 582 | } 583 | 584 | let pp_set_formatter_tag_functions state 585 | { 586 | mark_open_tag = mot; 587 | mark_close_tag = mct; 588 | print_open_tag = pot; 589 | print_close_tag = pct 590 | } = 591 | (state.pp_mark_open_tag <- mot; 592 | state.pp_mark_close_tag <- mct; 593 | state.pp_print_open_tag <- pot; 594 | state.pp_print_close_tag <- pct) 595 | 596 | (* Initialize pretty-printer. *) 597 | let pp_rinit state = 598 | (pp_clear_queue state; 599 | clear_scan_stack state; 600 | state.pp_format_stack <- []; 601 | state.pp_tbox_stack <- []; 602 | state.pp_tag_stack <- []; 603 | state.pp_mark_stack <- []; 604 | state.pp_current_indent <- 0; 605 | state.pp_curr_depth <- 0; 606 | state.pp_space_left <- state.pp_margin; 607 | pp_open_sys_box state) 608 | 609 | (* Flushing pretty-printer queue. *) 610 | let pp_flush_queue state b = 611 | (while state.pp_curr_depth > 1 do pp_close_box state () done; 612 | state.pp_right_total <- pp_infinity; 613 | advance_left state; 614 | if b then pp_output_newline state else (); 615 | pp_rinit state) 616 | 617 | (************************************************************** 618 | 619 | Procedures to format objects, and use boxes 620 | 621 | **************************************************************) 622 | (* To format a string. *) 623 | let pp_print_as_size state size s = 624 | if state.pp_curr_depth < state.pp_max_boxes 625 | then enqueue_string_as state size s 626 | else () 627 | 628 | let pp_print_as state isize s = pp_print_as_size state (size_of_int isize) s 629 | 630 | let pp_print_string state s = pp_print_as state (String.length s) s 631 | 632 | (* To format an integer. *) 633 | let pp_print_int state i = pp_print_string state (string_of_int i) 634 | 635 | (* To format a float. *) 636 | let pp_print_float state f = pp_print_string state (string_of_float f) 637 | 638 | (* To format a boolean. *) 639 | let pp_print_bool state b = pp_print_string state (string_of_bool b) 640 | 641 | (* To format a char. *) 642 | let pp_print_char state (c : char) = 643 | pp_print_as state 1 (string c) 644 | 645 | (* Opening boxes. *) 646 | let rec pp_open_hbox state () = pp_open_box_gen state 0 Pp_hbox 647 | and pp_open_vbox state indent = pp_open_box_gen state indent Pp_vbox 648 | and pp_open_hvbox state indent = pp_open_box_gen state indent Pp_hvbox 649 | and pp_open_hovbox state indent = pp_open_box_gen state indent Pp_hovbox 650 | and pp_open_box state indent = pp_open_box_gen state indent Pp_box 651 | 652 | (* Print a new line after printing all queued text 653 | (same for print_flush but without a newline). *) 654 | let rec pp_print_newline state () = 655 | pp_flush_queue state true 656 | state.pp_out_flush () 657 | and pp_print_flush state () = 658 | pp_flush_queue state false 659 | state.pp_out_flush () 660 | 661 | (* To get a newline when one does not want to close the current block. *) 662 | let pp_force_newline state () = 663 | if state.pp_curr_depth < state.pp_max_boxes 664 | then enqueue_advance state (make_queue_elem (size_of_int 0) Pp_newline 0) 665 | else () 666 | 667 | (* To format something if the line has just been broken. *) 668 | let pp_print_if_newline state () = 669 | if state.pp_curr_depth < state.pp_max_boxes 670 | then 671 | enqueue_advance state (make_queue_elem (size_of_int 0) Pp_if_newline 0) 672 | else () 673 | 674 | (* Breaks: indicate where a block may be broken. 675 | If line is broken then offset is added to the indentation of the current 676 | block else (the value of) width blanks are printed. 677 | To do (?) : add a maximum width and offset value. *) 678 | let pp_print_break state width offset = 679 | if state.pp_curr_depth < state.pp_max_boxes 680 | then 681 | (let elem = 682 | make_queue_elem (size_of_int (- state.pp_right_total)) 683 | (Pp_break (width, offset)) width 684 | in scan_push state true elem) 685 | else () 686 | 687 | let rec pp_print_space state () = pp_print_break state 1 0 688 | and pp_print_cut state () = pp_print_break state 0 0 689 | 690 | (* Tabulation boxes. *) 691 | let pp_open_tbox state () = 692 | (state.pp_curr_depth <- state.pp_curr_depth + 1; 693 | if state.pp_curr_depth < state.pp_max_boxes 694 | then 695 | (let elem = 696 | make_queue_elem (size_of_int 0) (Pp_tbegin (Pp_tbox (ref []))) 0 697 | in enqueue_advance state elem) 698 | else ()) 699 | 700 | (* Close a tabulation block. *) 701 | let pp_close_tbox state () = 702 | if state.pp_curr_depth > 1 703 | then 704 | if state.pp_curr_depth < state.pp_max_boxes 705 | then 706 | (let elem = make_queue_elem (size_of_int 0) Pp_tend 0 707 | in 708 | (enqueue_advance state elem; 709 | state.pp_curr_depth <- state.pp_curr_depth - 1)) 710 | else () 711 | else () 712 | 713 | (* Print a tabulation break. *) 714 | let pp_print_tbreak state width offset = 715 | if state.pp_curr_depth < state.pp_max_boxes 716 | then 717 | (let elem = 718 | make_queue_elem (size_of_int (- state.pp_right_total)) 719 | (Pp_tbreak (width, offset)) width 720 | in scan_push state true elem) 721 | else () 722 | 723 | let pp_print_tab state () = pp_print_tbreak state 0 0 724 | 725 | let pp_set_tab state () = 726 | if state.pp_curr_depth < state.pp_max_boxes 727 | then 728 | (let elem = make_queue_elem (size_of_int 0) Pp_stab 0 729 | in enqueue_advance state elem) 730 | else () 731 | 732 | (************************************************************** 733 | 734 | Procedures to control the pretty-printers 735 | 736 | **************************************************************) 737 | (* Fit max_boxes. *) 738 | let pp_set_max_boxes state n = if n > 1 then state.pp_max_boxes <- n else () 739 | 740 | (* To know the current maximum number of boxes allowed. *) 741 | let pp_get_max_boxes state () = state.pp_max_boxes 742 | 743 | let pp_over_max_boxes state () = state.pp_curr_depth = state.pp_max_boxes 744 | 745 | (* Ellipsis. *) 746 | let rec pp_set_ellipsis_text state s = state.pp_ellipsis <- s 747 | and pp_get_ellipsis_text state () = state.pp_ellipsis 748 | 749 | (* To set the margin of pretty-printer. *) 750 | let pp_limit n = if n < pp_infinity then n else pred pp_infinity 751 | 752 | let pp_set_min_space_left state n = 753 | if n >= 1 754 | then 755 | (let n = pp_limit n 756 | in 757 | (state.pp_min_space_left <- n; 758 | state.pp_max_indent <- state.pp_margin - state.pp_min_space_left; 759 | pp_rinit state)) 760 | else () 761 | 762 | (* Initially, we have : 763 | pp_max_indent = pp_margin - pp_min_space_left, and 764 | pp_space_left = pp_margin. *) 765 | let pp_set_max_indent state n = 766 | pp_set_min_space_left state (state.pp_margin - n) 767 | 768 | let pp_get_max_indent state () = state.pp_max_indent 769 | 770 | let pp_set_margin state n = 771 | if n >= 1 772 | then 773 | (let n = pp_limit n 774 | in 775 | (state.pp_margin <- n; 776 | let new_max_indent = 777 | (* Try to maintain max_indent to its actual value. *) 778 | if state.pp_max_indent <= state.pp_margin 779 | then state.pp_max_indent 780 | else 781 | (* If possible maintain pp_min_space_left to its actual value, 782 | if this leads to a too small max_indent, take half of the 783 | new margin, if it is greater than 1. *) 784 | max 785 | (max (state.pp_margin - state.pp_min_space_left) 786 | (state.pp_margin / 2)) 787 | 1 788 | in (* Rebuild invariants. *) pp_set_max_indent state new_max_indent)) 789 | else () 790 | 791 | let pp_get_margin state () = state.pp_margin 792 | 793 | type formatter_out_functions = { 794 | out_string : string -> int -> int -> unit; 795 | out_flush : unit -> unit; 796 | out_newline : unit -> unit; 797 | out_spaces : int -> unit 798 | } 799 | 800 | let pp_set_formatter_out_functions state 801 | { 802 | out_string = f; 803 | out_flush = g; 804 | out_newline = h; 805 | out_spaces = i 806 | } = 807 | state.pp_out_string <- f 808 | state.pp_out_flush <- g 809 | state.pp_out_newline <- h 810 | state.pp_out_spaces <- i 811 | 812 | let pp_get_formatter_out_functions state () = 813 | { 814 | out_string = state.pp_out_string; 815 | out_flush = state.pp_out_flush; 816 | out_newline = state.pp_out_newline; 817 | out_spaces = state.pp_out_spaces; 818 | } 819 | 820 | let pp_set_formatter_output_functions state f g = 821 | (state.pp_out_string <- f; state.pp_out_flush <- g) 822 | 823 | let pp_get_formatter_output_functions state () = 824 | state.pp_out_string, state.pp_out_flush 825 | 826 | //let pp_set_all_formatter_output_functions state ~out:f ~flush:g ~newline:h ~spaces:i = 827 | let pp_set_all_formatter_output_functions state f g h i = 828 | pp_set_formatter_output_functions state f g 829 | state.pp_out_newline <- h 830 | state.pp_out_spaces <- i 831 | 832 | let pp_get_all_formatter_output_functions state () = 833 | state.pp_out_string, 834 | state.pp_out_flush, 835 | state.pp_out_newline, 836 | state.pp_out_spaces 837 | 838 | (* Default function to output new lines. *) 839 | let display_newline state () = state.pp_out_string "\n" 0 1 840 | 841 | (* Default function to output spaces. *) 842 | let blank_line = String.make 80 ' ' 843 | 844 | let rec display_blanks state n = 845 | if n > 0 then 846 | if n <= 80 847 | then state.pp_out_string blank_line 0 n 848 | else (state.pp_out_string blank_line 0 80; display_blanks state (n - 80)) 849 | 850 | /// Re-implementation of OCaml's Pervasives.output, since the one in the 851 | /// F# compatibility library doesn't have the right type signature. 852 | let private output oc (buf : string) (pos : int) (len : int) = 853 | output_string oc (buf.Substring (pos, len)) 854 | 855 | let pp_set_formatter_out_channel state os = 856 | state.pp_out_string <- output os 857 | state.pp_out_flush <- (fun () -> flush os) 858 | state.pp_out_newline <- display_newline state 859 | state.pp_out_spaces <- display_blanks state 860 | 861 | (************************************************************** 862 | 863 | Creation of specific formatters 864 | 865 | **************************************************************) 866 | let default_pp_mark_open_tag s = "<" ^ (s ^ ">") 867 | 868 | let default_pp_mark_close_tag s = "") 869 | 870 | let default_pp_print_open_tag = ignore 871 | 872 | let default_pp_print_close_tag = ignore 873 | 874 | let pp_make_formatter f g h i = 875 | (* The initial state of the formatter contains a dummy box. *) 876 | let pp_q = make_queue () in 877 | let sys_tok = 878 | make_queue_elem (size_of_int (-1)) (Pp_begin (0, Pp_hovbox)) 0 879 | in 880 | (add_queue sys_tok pp_q; 881 | let sys_scan_stack = (Scan_elem (1, sys_tok)) :: scan_stack_bottom 882 | in 883 | { 884 | pp_scan_stack = sys_scan_stack; 885 | pp_format_stack = []; 886 | pp_tbox_stack = []; 887 | pp_tag_stack = []; 888 | pp_mark_stack = []; 889 | pp_margin = 78; 890 | pp_min_space_left = 10; 891 | pp_max_indent = 78 - 10; 892 | pp_space_left = 78; 893 | pp_current_indent = 0; 894 | pp_is_new_line = true; 895 | pp_left_total = 1; 896 | pp_right_total = 1; 897 | pp_curr_depth = 1; 898 | pp_max_boxes = max_int; 899 | pp_ellipsis = "."; 900 | pp_out_string = f; 901 | pp_out_flush = g; 902 | pp_out_newline = h; 903 | pp_out_spaces = i; 904 | pp_print_tags = false; 905 | pp_mark_tags = false; 906 | pp_mark_open_tag = default_pp_mark_open_tag; 907 | pp_mark_close_tag = default_pp_mark_close_tag; 908 | pp_print_open_tag = default_pp_print_open_tag; 909 | pp_print_close_tag = default_pp_print_close_tag; 910 | pp_queue = pp_q; 911 | }) 912 | 913 | (* Make a formatter with default functions to output spaces and new lines. *) 914 | let make_formatter output flush = 915 | let ppf = pp_make_formatter output flush ignore ignore 916 | in 917 | (ppf.pp_out_newline <- display_newline ppf; 918 | ppf.pp_out_spaces <- display_blanks ppf; 919 | ppf) 920 | 921 | let formatter_of_out_channel oc = 922 | make_formatter (output oc) (fun () -> flush oc) 923 | 924 | let formatter_of_buffer b = make_formatter (Buffer.add_substring b) ignore 925 | 926 | let stdbuf = Buffer.create 512 927 | 928 | (* Predefined formatters. *) 929 | let rec std_formatter = formatter_of_out_channel Pervasives.stdout 930 | and err_formatter = formatter_of_out_channel Pervasives.stderr 931 | and str_formatter = formatter_of_buffer stdbuf 932 | 933 | let flush_str_formatter () = 934 | (pp_flush_queue str_formatter false; 935 | let s = Buffer.contents stdbuf in (Buffer.reset stdbuf; s)) 936 | 937 | (************************************************************** 938 | 939 | Basic functions on the standard formatter 940 | 941 | **************************************************************) 942 | let rec open_hbox = pp_open_hbox std_formatter 943 | and open_vbox = pp_open_vbox std_formatter 944 | and open_hvbox = pp_open_hvbox std_formatter 945 | and open_hovbox = pp_open_hovbox std_formatter 946 | and open_box = pp_open_box std_formatter 947 | and close_box = pp_close_box std_formatter 948 | and open_tag = pp_open_tag std_formatter 949 | and close_tag = pp_close_tag std_formatter 950 | and print_as = pp_print_as std_formatter 951 | and print_string = pp_print_string std_formatter 952 | and print_int = pp_print_int std_formatter 953 | and print_float = pp_print_float std_formatter 954 | and print_char = pp_print_char std_formatter 955 | and print_bool = pp_print_bool std_formatter 956 | and print_break = pp_print_break std_formatter 957 | and print_cut = pp_print_cut std_formatter 958 | and print_space = pp_print_space std_formatter 959 | and force_newline = pp_force_newline std_formatter 960 | and print_flush = pp_print_flush std_formatter 961 | and print_newline = pp_print_newline std_formatter 962 | and print_if_newline = pp_print_if_newline std_formatter 963 | and open_tbox = pp_open_tbox std_formatter 964 | and close_tbox = pp_close_tbox std_formatter 965 | and print_tbreak = pp_print_tbreak std_formatter 966 | and set_tab = pp_set_tab std_formatter 967 | and print_tab = pp_print_tab std_formatter 968 | and set_margin = pp_set_margin std_formatter 969 | and get_margin = pp_get_margin std_formatter 970 | and set_max_indent = pp_set_max_indent std_formatter 971 | and get_max_indent = pp_get_max_indent std_formatter 972 | and set_max_boxes = pp_set_max_boxes std_formatter 973 | and get_max_boxes = pp_get_max_boxes std_formatter 974 | and over_max_boxes = pp_over_max_boxes std_formatter 975 | and set_ellipsis_text = pp_set_ellipsis_text std_formatter 976 | and get_ellipsis_text = pp_get_ellipsis_text std_formatter 977 | and set_formatter_out_channel (channel : out_channel) = 978 | pp_set_formatter_out_channel std_formatter channel 979 | and set_formatter_out_functions = 980 | pp_set_formatter_out_functions std_formatter 981 | and get_formatter_out_functions = 982 | pp_get_formatter_out_functions std_formatter 983 | and set_formatter_output_functions = 984 | pp_set_formatter_output_functions std_formatter 985 | and get_formatter_output_functions = 986 | pp_get_formatter_output_functions std_formatter 987 | and set_all_formatter_output_functions = 988 | pp_set_all_formatter_output_functions std_formatter 989 | and get_all_formatter_output_functions = 990 | pp_get_all_formatter_output_functions std_formatter 991 | and set_formatter_tag_functions = 992 | pp_set_formatter_tag_functions std_formatter 993 | and get_formatter_tag_functions = 994 | pp_get_formatter_tag_functions std_formatter 995 | and set_print_tags = pp_set_print_tags std_formatter 996 | and get_print_tags = pp_get_print_tags std_formatter 997 | and set_mark_tags = pp_set_mark_tags std_formatter 998 | and get_mark_tags = pp_get_mark_tags std_formatter 999 | and set_tags = pp_set_tags std_formatter 1000 | 1001 | (************************************************************** 1002 | 1003 | Printf implementation. 1004 | 1005 | **************************************************************) 1006 | module Sformat = Printf.Sformat 1007 | 1008 | module Tformat = Printf.CamlinternalPr.Tformat 1009 | 1010 | (* Error messages when processing formats. *) 1011 | (* Trailer: giving up at character number ... *) 1012 | let giving_up mess fmt i = 1013 | sprintf "Format.fprintf: %s ``%s'', giving up at character number %d%s" 1014 | mess (Sformat.to_string fmt) i 1015 | (if i < Sformat.length fmt 1016 | then sprintf " (%c)." (Sformat.get fmt i) 1017 | else sprintf "%c" '.') 1018 | 1019 | (* When an invalid format deserves a special error explanation. *) 1020 | let format_invalid_arg mess fmt i = invalid_arg (giving_up mess fmt i) 1021 | 1022 | (* Standard invalid format. *) 1023 | let invalid_format fmt i = format_invalid_arg "bad format" fmt i 1024 | 1025 | (* Cannot find a valid integer into that format. *) 1026 | let invalid_integer fmt i = 1027 | invalid_arg (giving_up "bad integer specification" fmt i) 1028 | 1029 | (* Finding an integer size out of a sub-string of the format. *) 1030 | let format_int_of_string fmt i s = 1031 | let sz = try int_of_string s with | Failure _ -> invalid_integer fmt i 1032 | in size_of_int sz 1033 | 1034 | (* Getting strings out of buffers. *) 1035 | let get_buffer_out b = let s = Buffer.contents b in (Buffer.reset b; s) 1036 | 1037 | (* [ppf] is supposed to be a pretty-printer that outputs to buffer [b]: 1038 | to extract the contents of [ppf] as a string we flush [ppf] and get the 1039 | string out of [b]. *) 1040 | let string_out b ppf = (pp_flush_queue ppf false; get_buffer_out b) 1041 | 1042 | (* Applies [printer] to a formatter that outputs on a fresh buffer, 1043 | then returns the resulting material. *) 1044 | let exstring printer arg = 1045 | let b = Buffer.create 512 in 1046 | let ppf = formatter_of_buffer b in (printer ppf arg; string_out b ppf) 1047 | 1048 | (* To turn out a character accumulator into the proper string result. *) 1049 | let implode_rev s0 = function 1050 | | [] -> s0 1051 | | l -> String.concat "" (List.rev (s0 :: l)) 1052 | 1053 | (* [mkprintf] is the printf-like function generator: given the 1054 | - [to_s] flag that tells if we are printing into a string, 1055 | - the [get_out] function that has to be called to get a [ppf] function to 1056 | output onto, 1057 | it generates a [kprintf] function that takes as arguments a [k] 1058 | continuation function to be called at the end of formatting, 1059 | and a printing format string to print the rest of the arguments 1060 | according to the format string. 1061 | Regular [fprintf]-like functions of this module are obtained via partial 1062 | applications of [mkprintf]. *) 1063 | let mkprintf to_s get_out = 1064 | let rec kprintf k fmt = 1065 | let len = Sformat.length fmt in 1066 | let kpr fmt v = 1067 | let ppf = get_out fmt in 1068 | let print_as = ref None in 1069 | let rec pp_print_as_char c = 1070 | match !print_as with 1071 | | None -> pp_print_char ppf c 1072 | | Some size -> 1073 | (pp_print_as_size ppf size (String.make 1 c); print_as := None) 1074 | and pp_print_as_string s = 1075 | match !print_as with 1076 | | None -> pp_print_string ppf s 1077 | | Some size -> (pp_print_as_size ppf size s; print_as := None) in 1078 | let rec doprn n i = 1079 | if i >= len 1080 | then Obj.magic (k ppf) 1081 | else 1082 | (match Sformat.get fmt i with 1083 | | '%' -> 1084 | Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f 1085 | cont_m 1086 | | '@' -> 1087 | let i = succ i 1088 | in 1089 | if i >= len 1090 | then invalid_format fmt i 1091 | else 1092 | (match Sformat.get fmt i with 1093 | | '[' -> do_pp_open_box ppf n (succ i) 1094 | | ']' -> (pp_close_box ppf (); doprn n (succ i)) 1095 | | '{' -> do_pp_open_tag ppf n (succ i) 1096 | | '}' -> (pp_close_tag ppf (); doprn n (succ i)) 1097 | | ' ' -> (pp_print_space ppf (); doprn n (succ i)) 1098 | | ',' -> (pp_print_cut ppf (); doprn n (succ i)) 1099 | | '?' -> (pp_print_flush ppf (); doprn n (succ i)) 1100 | | '.' -> (pp_print_newline ppf (); doprn n (succ i)) 1101 | | '\n' -> (pp_force_newline ppf (); doprn n (succ i)) 1102 | | ';' -> do_pp_break ppf n (succ i) 1103 | | '<' -> 1104 | let got_size size n i = 1105 | (print_as := Some size; doprn n (skip_gt i)) 1106 | in get_int n (succ i) got_size 1107 | | ('@' | '%' as c) -> 1108 | (pp_print_as_char c; doprn n (succ i)) 1109 | | _ -> invalid_format fmt i) 1110 | | c -> (pp_print_as_char c; doprn n (succ i))) 1111 | and cont_s n s i = (pp_print_as_string s; doprn n i) 1112 | and cont_a n printer arg i = 1113 | (if to_s 1114 | then 1115 | pp_print_as_string 1116 | ((Obj.magic printer : unit -> _ -> string) () arg) 1117 | else printer ppf arg; 1118 | doprn n i) 1119 | and cont_t n printer i = 1120 | (if to_s 1121 | then pp_print_as_string ((Obj.magic printer : unit -> string) ()) 1122 | else printer ppf; 1123 | doprn n i) 1124 | and cont_f n i = (pp_print_flush ppf (); doprn n i) 1125 | and cont_m n sfmt i = kprintf (Obj.magic (fun _ -> doprn n i)) sfmt 1126 | and get_int n i c = 1127 | if i >= len 1128 | then invalid_integer fmt i 1129 | else 1130 | (match Sformat.get fmt i with 1131 | | ' ' -> get_int n (succ i) c 1132 | | '%' -> 1133 | let rec cont_s n s i = c (format_int_of_string fmt i s) n i 1134 | and cont_a _n _printer _arg i = invalid_integer fmt i 1135 | and cont_t _n _printer i = invalid_integer fmt i 1136 | and cont_f _n i = invalid_integer fmt i 1137 | and cont_m _n _sfmt i = invalid_integer fmt i 1138 | in 1139 | Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f 1140 | cont_m 1141 | | _ -> 1142 | let rec get j = 1143 | if j >= len 1144 | then invalid_integer fmt j 1145 | else 1146 | (match Sformat.get fmt j with 1147 | | x when x >= '0' && x <= '9' -> 1148 | get (succ j) 1149 | | '-' -> get (succ j) 1150 | | _ -> 1151 | let size = 1152 | if j = i 1153 | then size_of_int 0 1154 | else 1155 | (let s = 1156 | Sformat.sub fmt (Sformat.index_of_int i) 1157 | (j - i) 1158 | in format_int_of_string fmt j s) 1159 | in c size n j) 1160 | in get i) 1161 | and skip_gt i = 1162 | if i >= len 1163 | then invalid_format fmt i 1164 | else 1165 | (match Sformat.get fmt i with 1166 | | ' ' -> skip_gt (succ i) 1167 | | '>' -> succ i 1168 | | _ -> invalid_format fmt i) 1169 | and get_box_kind i = 1170 | if i >= len 1171 | then (Pp_box, i) 1172 | else 1173 | (match Sformat.get fmt i with 1174 | | 'h' -> 1175 | let i = succ i 1176 | in 1177 | if i >= len 1178 | then (Pp_hbox, i) 1179 | else 1180 | (match Sformat.get fmt i with 1181 | | 'o' -> 1182 | let i = succ i 1183 | in 1184 | if i >= len 1185 | then format_invalid_arg "bad box format" fmt i 1186 | else 1187 | (match Sformat.get fmt i with 1188 | | 'v' -> (Pp_hovbox, (succ i)) 1189 | | c -> 1190 | format_invalid_arg 1191 | ("bad box name ho" ^ (String.make 1 c)) 1192 | fmt i) 1193 | | 'v' -> (Pp_hvbox, (succ i)) 1194 | | _ -> (Pp_hbox, i)) 1195 | | 'b' -> (Pp_box, (succ i)) 1196 | | 'v' -> (Pp_vbox, (succ i)) 1197 | | _ -> (Pp_box, i)) 1198 | and get_tag_name n i c = 1199 | let rec get accu n i j = 1200 | if j >= len 1201 | then 1202 | c 1203 | (implode_rev (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) 1204 | accu) 1205 | n j 1206 | else 1207 | (match Sformat.get fmt j with 1208 | | '>' -> 1209 | c 1210 | (implode_rev 1211 | (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) accu) 1212 | n j 1213 | | '%' -> 1214 | let s0 = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in 1215 | let rec cont_s n s i = get (s :: s0 :: accu) n i i 1216 | and cont_a n printer arg i = 1217 | let s = 1218 | if to_s 1219 | then (Obj.magic printer : unit -> _ -> string) () arg 1220 | else exstring printer arg 1221 | in get (s :: s0 :: accu) n i i 1222 | and cont_t n printer i = 1223 | let s = 1224 | if to_s 1225 | then (Obj.magic printer : unit -> string) () 1226 | else exstring (fun ppf () -> printer ppf) () 1227 | in get (s :: s0 :: accu) n i i 1228 | and cont_f _n i = 1229 | format_invalid_arg "bad tag name specification" fmt i 1230 | and cont_m _n _sfmt i = 1231 | format_invalid_arg "bad tag name specification" fmt i 1232 | in 1233 | Tformat.scan_format fmt v n j cont_s cont_a cont_t cont_f 1234 | cont_m 1235 | | _ -> get accu n i (succ j)) 1236 | in get [] n i i 1237 | and do_pp_break ppf n i = 1238 | if i >= len 1239 | then (pp_print_space ppf (); doprn n i) 1240 | else 1241 | (match Sformat.get fmt i with 1242 | | '<' -> 1243 | let rec got_nspaces nspaces n i = 1244 | get_int n i (got_offset nspaces) 1245 | and got_offset nspaces offset n i = 1246 | (pp_print_break ppf (int_of_size nspaces) 1247 | (int_of_size offset); 1248 | doprn n (skip_gt i)) 1249 | in get_int n (succ i) got_nspaces 1250 | | _c -> (pp_print_space ppf (); doprn n i)) 1251 | and do_pp_open_box ppf n i = 1252 | if i >= len 1253 | then (pp_open_box_gen ppf 0 Pp_box; doprn n i) 1254 | else 1255 | (match Sformat.get fmt i with 1256 | | '<' -> 1257 | let (kind, i) = get_box_kind (succ i) in 1258 | let got_size size n i = 1259 | (pp_open_box_gen ppf (int_of_size size) kind; 1260 | doprn n (skip_gt i)) 1261 | in get_int n i got_size 1262 | | _c -> (pp_open_box_gen ppf 0 Pp_box; doprn n i)) 1263 | and do_pp_open_tag ppf n i = 1264 | if i >= len 1265 | then (pp_open_tag ppf ""; doprn n i) 1266 | else 1267 | (match Sformat.get fmt i with 1268 | | '<' -> 1269 | let got_name tag_name n i = 1270 | (pp_open_tag ppf tag_name; doprn n (skip_gt i)) 1271 | in get_tag_name n (succ i) got_name 1272 | | _c -> (pp_open_tag ppf ""; doprn n i)) 1273 | in doprn (Sformat.index_of_int 0) 0 1274 | in Tformat.kapr kpr fmt 1275 | in kprintf 1276 | 1277 | (************************************************************** 1278 | 1279 | Defining [fprintf] and various flavors of [fprintf]. 1280 | 1281 | **************************************************************) 1282 | let kfprintf k ppf = mkprintf false (fun _ -> ppf) k 1283 | 1284 | let ikfprintf k ppf = Tformat.kapr (fun _ _ -> Obj.magic (k ppf)) 1285 | 1286 | let fprintf ppf = kfprintf ignore ppf 1287 | 1288 | let ifprintf ppf = ikfprintf ignore ppf 1289 | 1290 | let printf fmt = fprintf std_formatter fmt 1291 | 1292 | let eprintf fmt = fprintf err_formatter fmt 1293 | 1294 | let ksprintf k = 1295 | let b = Buffer.create 512 in 1296 | let k ppf = k (string_out b ppf) 1297 | in mkprintf true (fun _ -> formatter_of_buffer b) k 1298 | 1299 | let sprintf fmt = ksprintf (fun s -> s) fmt 1300 | 1301 | (************************************************************** 1302 | 1303 | Deprecated stuff. 1304 | 1305 | **************************************************************) 1306 | let kbprintf k b = mkprintf false (fun _ -> formatter_of_buffer b) k 1307 | 1308 | (* Deprecated error prone function bprintf. *) 1309 | let bprintf b = let k ppf = pp_flush_queue ppf false in kbprintf k b 1310 | 1311 | (* Deprecated alias for ksprintf. *) 1312 | let kprintf = ksprintf 1313 | 1314 | (* Output everything left in the pretty printer queue at end of execution. *) 1315 | let _ = at_exit print_flush 1316 | 1317 | --------------------------------------------------------------------------------