├── .gitignore ├── CONTRIBUTING.md ├── ChangeLog.md ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── app └── Main.hs ├── elm-language-server.cabal ├── elm-stuff └── 0.19.0 │ └── summary.dat ├── src ├── Analyze │ ├── Diagnostics.hs │ └── Search.hs ├── LSP │ ├── Data │ │ ├── Capabilities.hs │ │ ├── Diagnostic.hs │ │ ├── DocumentFilter.hs │ │ ├── DocumentSelector.hs │ │ ├── Error.hs │ │ ├── FileChangeType.hs │ │ ├── FileEvent.hs │ │ ├── FileSystemWatcher.hs │ │ ├── Header.hs │ │ ├── Location.hs │ │ ├── Message.hs │ │ ├── MessageError.hs │ │ ├── NotificationMethod.hs │ │ ├── Position.hs │ │ ├── Range.hs │ │ ├── Registration.hs │ │ ├── RequestMethod.hs │ │ ├── TextDocumentIdentifier.hs │ │ └── URI.hs │ ├── Log.hs │ ├── MessageHandler.hs │ ├── Misc.hs │ ├── Model.hs │ ├── Server.hs │ └── Update.hs ├── Misc.hs ├── Result.hs ├── Task.hs └── Version.hs ├── stack.yaml └── test ├── Spec.hs └── sample ├── elm-stuff ├── .lsp │ └── clone │ │ ├── elm.json │ │ └── src │ │ └── Main.elm └── 0.19.0 │ ├── Main.elmi │ ├── Main.elmo │ └── summary.dat ├── elm.json └── src └── Main.elm /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | *~ 3 | lc.log 4 | debug.log 5 | sample.txt 6 | sample2.txt 7 | 8 | dist 9 | .cabal-sandbox/ 10 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | ## Contributing 2 | 3 | ### Requirements 4 | 5 | #### Mac or Linux OS 6 | I've only worked on this on a mac. I think it'll work on linux but not 100% sure. 7 | For windows, I have no idea if it works but I haven't tried! 8 | 9 | #### Haskell 10 | Ideally be confident and proficient working in haskell. If you're new to haskell, please 11 | don't be discouraged from contributing. Any PR I'm happy to look at and iterate on! 12 | 13 | Also you need haskell and stack installed. Since we use stack, you don't have to worry 14 | about which version of haskell because stack takes care of all of that. 15 | 16 | #### LSP 17 | Be a bit familiar how the language server protocol works. 18 | 19 | 20 | ### Deciding what to work on 21 | 22 | I'm going to try to udpate the github issues with what good areas to contribute too. I'll try 23 | to keep the issues specific as to what the end goal is. If you poke around and see something 24 | that you think can be improved, feel free to work on that as well. Anything to improve this 25 | codebase is a welcome change. 26 | 27 | Additionally, I'll try to create and manage issues for what I'm working on as well, to avoid 28 | doing duplicate work. If you have a question about if something already exists or a feature, 29 | please open and issue and we can dicusss and find a path forward. 30 | 31 | A few general notes on contributing. 32 | 33 | - Try to avoid adding new dependencies unless it's really necessary 34 | - The types in haskell do a good job doing simple self-documenting, however if something you're 35 | working on is counter-intuitive then please add comments explaining why you're doing what you're 36 | doing 37 | 38 | 39 | Also, this a part-time project for me so if you open an issue or reach out it make take me a few days to get back to you. 40 | 41 | ## Layout of the project 42 | 43 | This project loosely following a headless elm archiecture style pattern. Before starting, let's review the LSP protocol. 44 | Briefly, it's a message passing system, with request messages which require a server response and a notification 45 | message that the server does not need to respond. You can think of these messages as subscriptions in the elm 46 | architecture. 47 | 48 | To start off, we launch the [server](src/LSP/Server.hs) which is just a loop reading stdin. Then the client posts 49 | a message in stdin for the server to read. 50 | 51 | We have a [model](src/LSP/Model.hs), which outlines the state of the language server and is initialized before 52 | we begin looping on stdin. Everytime we recieve a message from the client, we decode it and send it to the 53 | [message handler](src/LSP/MessageHandler.hs). Here we optionally preform some side-effect based on the message 54 | and return a `Msg` that describes both changes in the model and what should be sent back to the client 55 | (the latter functionality of the `Msg` may be reworked in the future). This message and the model are passed to the 56 | [update function](src/LSP/Update.hs), which returns the new model and possibly some data to send back to the client. 57 | Then we watch stdin with the new model waiting for the next message. 58 | 59 | Generally, most features will involve adding in the message type to decode from the client, adding a handler for 60 | that message that does some work and/or updates the model, then adding encoding for what the server should 61 | respond to the client with. 62 | 63 | Another thing to note is that each message handler function returns a [`Task`](src/LSP/Task.hs). A task is meant to 64 | represent a side-effect that can either succeed or fail (it's just an `Either` wrapped in an `IO` that's a custom 65 | type). This is used easily model side-effects with various errors and to use functions that we pull from the elm-compiler 66 | easily. This type is the cornerstone of how this project manages side-effects. 67 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for elm-language-server 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Jared Ramirez (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Jared Ramirez nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: build build-deps watch install test 2 | 3 | build: 4 | stack build 5 | 6 | build-deps: 7 | stack build --only-dependencies 8 | 9 | watch: 10 | stack build --file-watch 11 | 12 | install: 13 | stack build --copy-bins 14 | 15 | test: 16 | stack test 17 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # elm-language-server 2 | 3 | This project implements the [Language Server Protocol](https://microsoft.github.io/language-server-protocol/) for Elm. 4 | 5 | ## Notice 6 | 7 | This project is on pause while I'm working on [an error tolerent parser and type solver](https://github.com/jaredramirez/elm-grammar). This will allow for much better diagnostics, type inference, and completion. 8 | 9 | This was shift if focus was inspired by the comments made [here](https://elmtown.simplecast.fm/it-just-goes-on-and-on). 10 | 11 | ## Platforms 12 | 13 | Currently this project only supports MacOS. I'm fairly certain that it works on most linux distros, but I have not tested on it. This is mostly beacuse I'm not an expert on how cross-compiling works with GHC and haven't tackled the problem yet. I'm not sure how it will work on windows at this point. 14 | 15 | ## Installation 16 | 17 | First, download the latest binary from the releases page. 18 | 19 | ### Neovim 20 | 21 | * Make sure the elm-language-server binary is either a) available on your path, or b) have an absolute path to wherever the binary is stored 22 | * Install and setup [neovim](https://neovim.io/) 23 | * Install [neovim language client](https://github.com/autozimu/LanguageClient-neovim) 24 | 25 | * Append your config with the following: 26 | 27 | ``` 28 | set hidden 29 | 30 | let g:LanguageClient_serverCommands = { 31 | \ 'elm': ['elm-language-server-exe'], 32 | " OR 33 | \ 'elm': ['/path/to/elm-language-server-exe'], 34 | \ } 35 | ``` 36 | 37 | ## Features 38 | 39 | This project is still in pretty early development, so the feature set is currently limited. 40 | 41 | * As-you-type diagnostics (compiler errors, etc) 42 | * Find and use either global or local (node_modules) elm installations to get diagnostics 43 | 44 | ## Contributing 45 | 46 | Check out [`CONTRIBUTING.md`](CONTRIBUTING.md). 47 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified LSP.Server 4 | 5 | main :: IO Int 6 | main = LSP.Server.run 7 | -------------------------------------------------------------------------------- /elm-language-server.cabal: -------------------------------------------------------------------------------- 1 | name: elm-language-server 2 | version: 0.0.1 3 | description: Please see the README on GitHub at 4 | homepage: https://github.com/jaredramirez/elm-language-server#readme 5 | bug-reports: https://github.com/jaredramirez/elm-language-server/issues 6 | author: Jared Ramirez 7 | maintainer: jaredramirez@me.com 8 | copyright: 2018 Jared Ramirez 9 | license: BSD3 10 | license-file: LICENSE 11 | build-type: Simple 12 | cabal-version: >= 1.10 13 | extra-source-files: 14 | ChangeLog.md 15 | README.md 16 | 17 | source-repository head 18 | type: git 19 | location: https://github.com/jaredramirez/elm-language-server 20 | 21 | flag dev { 22 | description: Turn off optimization and make warnings errors 23 | default: False 24 | } 25 | 26 | library 27 | ghc-options: 28 | -O2 -Wall -Wno-name-shadowing 29 | 30 | hs-source-dirs: 31 | src 32 | 33 | other-extensions: TemplateHaskell 34 | 35 | exposed-modules: 36 | LSP.Server 37 | 38 | -- Exposed for testing 39 | Analyze.Search 40 | LSP.Misc 41 | Misc 42 | Task 43 | 44 | other-modules: 45 | Analyze.Diagnostics 46 | LSP.Data.Capabilities 47 | LSP.Data.Diagnostic 48 | LSP.Data.DocumentFilter 49 | LSP.Data.DocumentSelector 50 | LSP.Data.Error 51 | LSP.Data.FileChangeType 52 | LSP.Data.FileEvent 53 | LSP.Data.FileSystemWatcher 54 | LSP.Data.Header 55 | LSP.Data.Location 56 | LSP.Data.Message 57 | LSP.Data.MessageError 58 | LSP.Data.NotificationMethod 59 | LSP.Data.Position 60 | LSP.Data.Range 61 | LSP.Data.Registration 62 | LSP.Data.RequestMethod 63 | LSP.Data.TextDocumentIdentifier 64 | LSP.Data.URI 65 | LSP.Log 66 | LSP.MessageHandler 67 | LSP.Model 68 | LSP.Update 69 | Paths_elm_language_server 70 | Result 71 | 72 | build-depends: 73 | base >=4.8 && <5 74 | , elm 75 | , aeson 76 | , aeson-utils 77 | , base >=4.8 && <5 78 | , binary >= 0.8 && < 0.9 79 | , bytestring >=0.9 && <0.11 80 | , containers >=0.5.8.2 && <0.6 81 | , directory >=1.2.3.0 && <2.0 82 | , filepath >=1 && <2.0 83 | , hashable 84 | , json >= 0.9.1 && < 0.10 85 | , mtl >= 2.2.1 && < 3 86 | , process 87 | , parsec >= 3.1.11 && < 4 88 | , Glob 89 | , split >= 0.2.3.1 && < 0.3 90 | , text >=1 && <2 91 | , unordered-containers 92 | , utf8-string 93 | , vector 94 | 95 | default-language: Haskell2010 96 | 97 | executable elm-language-server-exe 98 | ghc-options: 99 | -O2 -Wall -Wno-name-shadowing 100 | 101 | main-is: Main.hs 102 | 103 | hs-source-dirs: 104 | app 105 | 106 | other-extensions: TemplateHaskell 107 | 108 | build-depends: 109 | base >=4.8 && <5 110 | , elm-language-server 111 | 112 | default-language: Haskell2010 113 | 114 | test-suite elm-language-server-test 115 | type: exitcode-stdio-1.0 116 | 117 | main-is: Spec.hs 118 | 119 | other-modules: 120 | Paths_elm_language_server 121 | 122 | hs-source-dirs: 123 | test 124 | 125 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 126 | 127 | build-depends: 128 | base >=4.8 && <5 129 | , elm 130 | , elm-language-server 131 | , tasty 132 | , tasty-hunit 133 | , bytestring >=0.9 && <0.11 134 | , text >=1 && <2 135 | , containers >=0.5.8.2 && <0.6 136 | 137 | default-language: Haskell2010 138 | -------------------------------------------------------------------------------- /elm-stuff/0.19.0/summary.dat: -------------------------------------------------------------------------------- 1 | elmcoreelmjsonArrayelmcoreBasicselmcoreBitwiseelmcoreCharelmcoreDebugelmcoreDictelmcoreListelmcoreMaybeelmcorePlatformelmcore Platform.Cmdelmcore Platform.SubelmcoreProcesselmcoreResultelmcoreSetelmcoreStringelmcoreTaskelmcoreTupleelmcoreelmcoreArrayappendaelmcoreArrayArrayaelmcoreArrayArrayaelmcoreArrayArrayaemptyaelmcoreArrayArrayafilteraaelmcoreBasicsBoolelmcoreArrayArrayaelmcoreArrayArrayafoldlababbbelmcoreArrayArrayabfoldrababbbelmcoreArrayArrayabfromListaelmcoreListListaelmcoreArrayArrayagetaelmcoreBasicsIntelmcoreArrayArrayaelmcoreMaybeMaybea 2 | indexedMapabelmcoreBasicsIntabelmcoreArrayArrayaelmcoreArrayArrayb 3 | initializeaelmcoreBasicsIntelmcoreBasicsIntaelmcoreArrayArrayaisEmptyaelmcoreArrayArrayaelmcoreBasicsBoollengthaelmcoreArrayArrayaelmcoreBasicsIntmapababelmcoreArrayArrayaelmcoreArrayArraybpushaaelmcoreArrayArrayaelmcoreArrayArrayarepeataelmcoreBasicsIntaelmcoreArrayArrayasetaelmcoreBasicsIntaelmcoreArrayArrayaelmcoreArrayArrayasliceaelmcoreBasicsIntelmcoreBasicsIntelmcoreArrayArrayaelmcoreArrayArraya toIndexedListaelmcoreArrayArrayaelmcoreListListelmcoreBasicsIntatoListaelmcoreArrayArrayaelmcoreListListaArrayaArray_elm_builtinelmcoreBasicsIntelmcoreBasicsIntelmcoreArrayTreeaaelmcore Elm.JsArrayJsArrayelmcoreArrayNodeaelmcore Elm.JsArrayJsArrayaNodeaSubTreeelmcoreArrayTreeaaelmcore Elm.JsArrayJsArrayelmcoreArrayNodeaLeafelmcore Elm.JsArrayJsArrayaBuilderanodeListelmcoreListListelmcoreArrayNodea nodeListSizeelmcoreBasicsInttailelmcore Elm.JsArrayJsArrayaTreeaelmcore Elm.JsArrayJsArrayelmcoreArrayNodeaelmcoreBasics$absnumbernumbernumberacoselmcoreBasicsFloatelmcoreBasicsFloatalwaysababaasinelmcoreBasicsFloatelmcoreBasicsFloatatanelmcoreBasicsFloatelmcoreBasicsFloatatan2elmcoreBasicsFloatelmcoreBasicsFloatelmcoreBasicsFloatceilingelmcoreBasicsFloatelmcoreBasicsIntclampnumbernumbernumbernumbernumbercompare 4 | comparable 5 | comparable 6 | comparableelmcoreBasicsOrdercoselmcoreBasicsFloatelmcoreBasicsFloatdegreeselmcoreBasicsFloatelmcoreBasicsFloateelmcoreBasicsFloatfloorelmcoreBasicsFloatelmcoreBasicsInt fromPolarelmcoreBasicsFloatelmcoreBasicsFloatelmcoreBasicsFloatelmcoreBasicsFloatidentityaaa 7 | isInfiniteelmcoreBasicsFloatelmcoreBasicsBoolisNaNelmcoreBasicsFloatelmcoreBasicsBoollogBaseelmcoreBasicsFloatelmcoreBasicsFloatelmcoreBasicsFloatmax 8 | comparable 9 | comparable 10 | comparable 11 | comparablemin 12 | comparable 13 | comparable 14 | comparable 15 | comparablemodByelmcoreBasicsIntelmcoreBasicsIntelmcoreBasicsIntnegatenumbernumbernumberneveraelmcoreBasicsNeveranotelmcoreBasicsBoolelmcoreBasicsBoolpielmcoreBasicsFloatradianselmcoreBasicsFloatelmcoreBasicsFloat remainderByelmcoreBasicsIntelmcoreBasicsIntelmcoreBasicsIntroundelmcoreBasicsFloatelmcoreBasicsIntsinelmcoreBasicsFloatelmcoreBasicsFloatsqrtelmcoreBasicsFloatelmcoreBasicsFloattanelmcoreBasicsFloatelmcoreBasicsFloattoFloatelmcoreBasicsIntelmcoreBasicsFloattoPolarelmcoreBasicsFloatelmcoreBasicsFloatelmcoreBasicsFloatelmcoreBasicsFloattruncateelmcoreBasicsFloatelmcoreBasicsIntturnselmcoreBasicsFloatelmcoreBasicsFloatxorelmcoreBasicsBoolelmcoreBasicsBoolelmcoreBasicsBoolBoolTrueFalseFloatFloatIntIntNever JustOneMoreelmcoreBasicsNeverOrderLTEQGT&&andelmcoreBasicsBoolelmcoreBasicsBoolelmcoreBasicsBool*mulnumbernumbernumbernumber+addnumbernumbernumbernumber++append 16 | appendable 17 | appendable 18 | appendable 19 | appendable-subnumbernumbernumbernumber/fdivelmcoreBasicsFloatelmcoreBasicsFloatelmcoreBasicsFloat//idivelmcoreBasicsIntelmcoreBasicsIntelmcoreBasicsInt/=neqaaaelmcoreBasicsBool<lt 20 | comparable 21 | comparable 22 | comparableelmcoreBasicsBool<<composeLabcbcabac <=le 23 | comparable 24 | comparable 25 | comparableelmcoreBasicsBool<|apLababab==eqaaaelmcoreBasicsBool>gt 26 | comparable 27 | comparable 28 | comparableelmcoreBasicsBool>=ge 29 | comparable 30 | comparable 31 | comparableelmcoreBasicsBool>>composeRabcabbcac ^pownumbernumbernumbernumber|>apRabaabb||orelmcoreBasicsBoolelmcoreBasicsBoolelmcoreBasicsBoolelmcoreBitwiseandelmcoreBasicsIntelmcoreBasicsIntelmcoreBasicsInt 32 | complementelmcoreBasicsIntelmcoreBasicsIntorelmcoreBasicsIntelmcoreBasicsIntelmcoreBasicsInt shiftLeftByelmcoreBasicsIntelmcoreBasicsIntelmcoreBasicsInt shiftRightByelmcoreBasicsIntelmcoreBasicsIntelmcoreBasicsIntshiftRightZfByelmcoreBasicsIntelmcoreBasicsIntelmcoreBasicsIntxorelmcoreBasicsIntelmcoreBasicsIntelmcoreBasicsIntelmcoreChar fromCodeelmcoreBasicsIntelmcoreCharCharisAlphaelmcoreCharCharelmcoreBasicsBool 33 | isAlphaNumelmcoreCharCharelmcoreBasicsBoolisDigitelmcoreCharCharelmcoreBasicsBool 34 | isHexDigitelmcoreCharCharelmcoreBasicsBoolisLowerelmcoreCharCharelmcoreBasicsBool 35 | isOctDigitelmcoreCharCharelmcoreBasicsBoolisUpperelmcoreCharCharelmcoreBasicsBooltoCodeelmcoreCharCharelmcoreBasicsInt toLocaleLowerelmcoreCharCharelmcoreCharChar toLocaleUpperelmcoreCharCharelmcoreCharChartoLowerelmcoreCharCharelmcoreCharChartoUpperelmcoreCharCharelmcoreCharCharCharCharelmcoreDebuglogaelmcoreStringStringaatoStringaaelmcoreStringStringtodoaelmcoreStringStringaelmcoreDictdiffab 36 | comparable elmcoreDictDict 37 | comparablea elmcoreDictDict 38 | comparableb elmcoreDictDict 39 | comparableaemptykv elmcoreDictDictkvfilter 40 | comparablev 41 | comparablevelmcoreBasicsBool elmcoreDictDict 42 | comparablev elmcoreDictDict 43 | comparablevfoldlbkvkvbbb elmcoreDictDictkvbfoldrbkvkvbbb elmcoreDictDictkvbfromList 44 | comparablevelmcoreListList 45 | comparablev elmcoreDictDict 46 | comparablevget 47 | comparablev 48 | comparable elmcoreDictDict 49 | comparablevelmcoreMaybeMaybevinsert 50 | comparablev 51 | comparablev elmcoreDictDict 52 | comparablev elmcoreDictDict 53 | comparablev intersect 54 | comparablev elmcoreDictDict 55 | comparablev elmcoreDictDict 56 | comparablev elmcoreDictDict 57 | comparablevisEmptykv elmcoreDictDictkvelmcoreBasicsBoolkeyskv elmcoreDictDictkvelmcoreListListkmapabkkab elmcoreDictDictka elmcoreDictDictkbmember 58 | comparablev 59 | comparable elmcoreDictDict 60 | comparablevelmcoreBasicsBoolmergeab 61 | comparableresult 62 | comparablearesultresult 63 | comparableabresultresult 64 | comparablebresultresult elmcoreDictDict 65 | comparablea elmcoreDictDict 66 | comparablebresultresult partition 67 | comparablev 68 | comparablevelmcoreBasicsBool elmcoreDictDict 69 | comparablev elmcoreDictDict 70 | comparablev elmcoreDictDict 71 | comparablevremove 72 | comparablev 73 | comparable elmcoreDictDict 74 | comparablev elmcoreDictDict 75 | comparablev singleton 76 | comparablev 77 | comparablev elmcoreDictDict 78 | comparablevsizekv elmcoreDictDictkvelmcoreBasicsInttoListkv elmcoreDictDictkvelmcoreListListkvunion 79 | comparablev elmcoreDictDict 80 | comparablev elmcoreDictDict 81 | comparablev elmcoreDictDict 82 | comparablevupdate 83 | comparablev 84 | comparableelmcoreMaybeMaybevelmcoreMaybeMaybev elmcoreDictDict 85 | comparablev elmcoreDictDict 86 | comparablevvalueskv elmcoreDictDictkvelmcoreListListvDictkvRBNode_elm_builtinelmcoreDictNColorkv elmcoreDictDictkv elmcoreDictDictkvRBEmpty_elm_builtinNColorRedBlackelmcoreList$allaaelmcoreBasicsBoolelmcoreListListaelmcoreBasicsBoolanyaaelmcoreBasicsBoolelmcoreListListaelmcoreBasicsBoolappendaelmcoreListListaelmcoreListListaelmcoreListListaconcataelmcoreListListelmcoreListListaelmcoreListLista concatMapabaelmcoreListListbelmcoreListListaelmcoreListListbdropaelmcoreBasicsIntelmcoreListListaelmcoreListListafilteraaelmcoreBasicsBoolelmcoreListListaelmcoreListLista filterMapabaelmcoreMaybeMaybebelmcoreListListaelmcoreListListbfoldlababbbelmcoreListListabfoldrababbbelmcoreListListabheadaelmcoreListListaelmcoreMaybeMaybea 87 | indexedMapabelmcoreBasicsIntabelmcoreListListaelmcoreListListb intersperseaaelmcoreListListaelmcoreListListaisEmptyaelmcoreListListaelmcoreBasicsBoollengthaelmcoreListListaelmcoreBasicsIntmapababelmcoreListListaelmcoreListListbmap2abresultabresultelmcoreListListaelmcoreListListbelmcoreListListresultmap3abcresultabcresultelmcoreListListaelmcoreListListbelmcoreListListcelmcoreListListresultmap4abcdresultabcdresultelmcoreListListaelmcoreListListbelmcoreListListcelmcoreListListdelmcoreListListresultmap5abcderesultabcderesultelmcoreListListaelmcoreListListbelmcoreListListcelmcoreListListdelmcoreListListeelmcoreListListresultmaximum 88 | comparableelmcoreListList 89 | comparableelmcoreMaybeMaybe 90 | comparablememberaaelmcoreListListaelmcoreBasicsBoolminimum 91 | comparableelmcoreListList 92 | comparableelmcoreMaybeMaybe 93 | comparable partitionaaelmcoreBasicsBoolelmcoreListListaelmcoreListListaelmcoreListListaproductnumberelmcoreListListnumbernumberrangeelmcoreBasicsIntelmcoreBasicsIntelmcoreListListelmcoreBasicsIntrepeataelmcoreBasicsIntaelmcoreListListareverseaelmcoreListListaelmcoreListLista singletonaaelmcoreListListasort 94 | comparableelmcoreListList 95 | comparableelmcoreListList 96 | comparablesortBya 97 | comparablea 98 | comparableelmcoreListListaelmcoreListListasortWithaaaelmcoreBasicsOrderelmcoreListListaelmcoreListListasumnumberelmcoreListListnumbernumbertailaelmcoreListListaelmcoreMaybeMaybeelmcoreListListatakeaelmcoreBasicsIntelmcoreListListaelmcoreListListaunzipabelmcoreListListabelmcoreListListaelmcoreListListb::consaaelmcoreListListaelmcoreListListaelmcoreMaybeandThenabaelmcoreMaybeMaybebelmcoreMaybeMaybeaelmcoreMaybeMaybebmapababelmcoreMaybeMaybeaelmcoreMaybeMaybebmap2abvalueabvalueelmcoreMaybeMaybeaelmcoreMaybeMaybebelmcoreMaybeMaybevaluemap3abcvalueabcvalueelmcoreMaybeMaybeaelmcoreMaybeMaybebelmcoreMaybeMaybecelmcoreMaybeMaybevaluemap4abcdvalueabcdvalueelmcoreMaybeMaybeaelmcoreMaybeMaybebelmcoreMaybeMaybecelmcoreMaybeMaybedelmcoreMaybeMaybevaluemap5abcdevalueabcdevalueelmcoreMaybeMaybeaelmcoreMaybeMaybebelmcoreMaybeMaybecelmcoreMaybeMaybedelmcoreMaybeMaybeeelmcoreMaybeMaybevalue withDefaultaaelmcoreMaybeMaybeaaMaybeaJustaNothingelmcorePlatform sendToAppamsgx elmcorePlatformRoutermsgamsg elmcorePlatformTaskx 99 | sendToSelfamsgx elmcorePlatformRouteramsgmsg elmcorePlatformTaskxworkerflagsmodelmsginitflagsmodelelmcore Platform.CmdCmdmsg subscriptionsmodelelmcore Platform.SubSubmsgupdatemsgmodelmodelelmcore Platform.CmdCmdmsg 100 | elmcorePlatformProgramflagsmodelmsg ProcessId ProcessIdProgramflagsmodelmsgProgramRouterappMsgselfMsgRouterTaskerrokTaskelmcore Platform.CmdbatchmsgelmcoreListListelmcore Platform.CmdCmdmsgelmcore Platform.CmdCmdmsgmapamsgamsgelmcore Platform.CmdCmdaelmcore Platform.CmdCmdmsgnonemsgelmcore Platform.CmdCmdmsgCmdmsgCmdelmcore Platform.SubbatchmsgelmcoreListListelmcore Platform.SubSubmsgelmcore Platform.SubSubmsgmapamsgamsgelmcore Platform.SubSubaelmcore Platform.SubSubmsgnonemsgelmcore Platform.SubSubmsgSubmsgSubelmcoreProcesskillxelmcoreProcessIdelmcorePlatform ProcessIdelmcoreTaskTaskxxa elmcorePlatformTaskxsleepxelmcoreBasicsFloatelmcoreTaskTaskxxa elmcorePlatformTaskxspawnaxyelmcoreTaskTaskxxaa elmcorePlatformTaskxaelmcoreTaskTaskxyaelmcoreProcessIdelmcorePlatform ProcessId elmcorePlatformTaskyelmcoreProcessIdelmcorePlatform ProcessIdIdelmcorePlatform ProcessIdelmcoreResult 101 | andThenabxa elmcoreResultResultxb elmcoreResultResultxa elmcoreResultResultxb fromMaybeaxxelmcoreMaybeMaybea elmcoreResultResultxamapavaluexavalue elmcoreResultResultxa elmcoreResultResultxvaluemap2abvaluexabvalue elmcoreResultResultxa elmcoreResultResultxb elmcoreResultResultxvaluemap3abcvaluexabcvalue elmcoreResultResultxa elmcoreResultResultxb elmcoreResultResultxc elmcoreResultResultxvaluemap4abcdvaluexabcdvalue elmcoreResultResultxa elmcoreResultResultxb elmcoreResultResultxc elmcoreResultResultxd elmcoreResultResultxvaluemap5abcdevaluexabcdevalue elmcoreResultResultxa elmcoreResultResultxb elmcoreResultResultxc elmcoreResultResultxd elmcoreResultResultxe elmcoreResultResultxvaluemapErroraxyxy elmcoreResultResultxa elmcoreResultResultyatoMaybeax elmcoreResultResultxaelmcoreMaybeMaybea withDefaultaxa elmcoreResultResultxaaResulterrorvalueOkvalueErrerrorelmcoreSetdiff 102 | comparableelmcoreSetSet 103 | comparableelmcoreSetSet 104 | comparableelmcoreSetSet 105 | comparableemptyaelmcoreSetSetafilter 106 | comparable 107 | comparableelmcoreBasicsBoolelmcoreSetSet 108 | comparableelmcoreSetSet 109 | comparablefoldlababbbelmcoreSetSetabfoldrababbbelmcoreSetSetabfromList 110 | comparableelmcoreListList 111 | comparableelmcoreSetSet 112 | comparableinsert 113 | comparable 114 | comparableelmcoreSetSet 115 | comparableelmcoreSetSet 116 | comparable intersect 117 | comparableelmcoreSetSet 118 | comparableelmcoreSetSet 119 | comparableelmcoreSetSet 120 | comparableisEmptyaelmcoreSetSetaelmcoreBasicsBoolmap 121 | comparable comparable2 122 | comparable comparable2elmcoreSetSet 123 | comparableelmcoreSetSet comparable2member 124 | comparable 125 | comparableelmcoreSetSet 126 | comparableelmcoreBasicsBool partition 127 | comparable 128 | comparableelmcoreBasicsBoolelmcoreSetSet 129 | comparableelmcoreSetSet 130 | comparableelmcoreSetSet 131 | comparableremove 132 | comparable 133 | comparableelmcoreSetSet 134 | comparableelmcoreSetSet 135 | comparable singleton 136 | comparable 137 | comparableelmcoreSetSet 138 | comparablesizeaelmcoreSetSetaelmcoreBasicsInttoListaelmcoreSetSetaelmcoreListListaunion 139 | comparableelmcoreSetSet 140 | comparableelmcoreSetSet 141 | comparableelmcoreSetSet 142 | comparableSettSet_elm_builtin elmcoreDictDicttelmcoreString,allelmcoreCharCharelmcoreBasicsBoolelmcoreStringStringelmcoreBasicsBoolanyelmcoreCharCharelmcoreBasicsBoolelmcoreStringStringelmcoreBasicsBoolappendelmcoreStringStringelmcoreStringStringelmcoreStringStringconcatelmcoreListListelmcoreStringStringelmcoreStringStringconselmcoreCharCharelmcoreStringStringelmcoreStringStringcontainselmcoreStringStringelmcoreStringStringelmcoreBasicsBooldropLeftelmcoreBasicsIntelmcoreStringStringelmcoreStringString dropRightelmcoreBasicsIntelmcoreStringStringelmcoreStringStringendsWithelmcoreStringStringelmcoreStringStringelmcoreBasicsBoolfilterelmcoreCharCharelmcoreBasicsBoolelmcoreStringStringelmcoreStringStringfoldlbelmcoreCharCharbbbelmcoreStringStringbfoldrbelmcoreCharCharbbbelmcoreStringStringbfromCharelmcoreCharCharelmcoreStringString fromFloatelmcoreBasicsFloatelmcoreStringStringfromIntelmcoreBasicsIntelmcoreStringStringfromListelmcoreListListelmcoreCharCharelmcoreStringStringindexeselmcoreStringStringelmcoreStringStringelmcoreListListelmcoreBasicsIntindiceselmcoreStringStringelmcoreStringStringelmcoreListListelmcoreBasicsIntisEmptyelmcoreStringStringelmcoreBasicsBooljoinelmcoreStringStringelmcoreListListelmcoreStringStringelmcoreStringStringleftelmcoreBasicsIntelmcoreStringStringelmcoreStringStringlengthelmcoreStringStringelmcoreBasicsIntlineselmcoreStringStringelmcoreListListelmcoreStringStringmapelmcoreCharCharelmcoreCharCharelmcoreStringStringelmcoreStringStringpadelmcoreBasicsIntelmcoreCharCharelmcoreStringStringelmcoreStringStringpadLeftelmcoreBasicsIntelmcoreCharCharelmcoreStringStringelmcoreStringStringpadRightelmcoreBasicsIntelmcoreCharCharelmcoreStringStringelmcoreStringStringrepeatelmcoreBasicsIntelmcoreStringStringelmcoreStringStringreplaceelmcoreStringStringelmcoreStringStringelmcoreStringStringelmcoreStringStringreverseelmcoreStringStringelmcoreStringStringrightelmcoreBasicsIntelmcoreStringStringelmcoreStringStringsliceelmcoreBasicsIntelmcoreBasicsIntelmcoreStringStringelmcoreStringStringsplitelmcoreStringStringelmcoreStringStringelmcoreListListelmcoreStringString 143 | startsWithelmcoreStringStringelmcoreStringStringelmcoreBasicsBooltoFloatelmcoreStringStringelmcoreMaybeMaybeelmcoreBasicsFloattoIntelmcoreStringStringelmcoreMaybeMaybeelmcoreBasicsInttoListelmcoreStringStringelmcoreListListelmcoreCharChartoLowerelmcoreStringStringelmcoreStringStringtoUpperelmcoreStringStringelmcoreStringStringtrimelmcoreStringStringelmcoreStringStringtrimLeftelmcoreStringStringelmcoreStringString trimRightelmcoreStringStringelmcoreStringStringunconselmcoreStringStringelmcoreMaybeMaybeelmcoreCharCharelmcoreStringStringwordselmcoreStringStringelmcoreListListelmcoreStringStringStringStringelmcoreTask andThenabxaelmcoreTaskTaskxxab elmcorePlatformTaskxbelmcoreTaskTaskxxaa elmcorePlatformTaskxaelmcoreTaskTaskxxab elmcorePlatformTaskxbattemptamsgx elmcoreResultResultxamsgelmcoreTaskTaskxxaa elmcorePlatformTaskxaelmcore Platform.CmdCmdmsgfailaxxelmcoreTaskTaskxxaa elmcorePlatformTaskxamapabxabelmcoreTaskTaskxxaa elmcorePlatformTaskxaelmcoreTaskTaskxxab elmcorePlatformTaskxbmap2abresultxabresultelmcoreTaskTaskxxaa elmcorePlatformTaskxaelmcoreTaskTaskxxab elmcorePlatformTaskxbelmcoreTaskTaskxxaresult elmcorePlatformTaskxresultmap3abcresultxabcresultelmcoreTaskTaskxxaa elmcorePlatformTaskxaelmcoreTaskTaskxxab elmcorePlatformTaskxbelmcoreTaskTaskxxac elmcorePlatformTaskxcelmcoreTaskTaskxxaresult elmcorePlatformTaskxresultmap4abcdresultxabcdresultelmcoreTaskTaskxxaa elmcorePlatformTaskxaelmcoreTaskTaskxxab elmcorePlatformTaskxbelmcoreTaskTaskxxac elmcorePlatformTaskxcelmcoreTaskTaskxxad elmcorePlatformTaskxdelmcoreTaskTaskxxaresult elmcorePlatformTaskxresultmap5abcderesultxabcderesultelmcoreTaskTaskxxaa elmcorePlatformTaskxaelmcoreTaskTaskxxab elmcorePlatformTaskxbelmcoreTaskTaskxxac elmcorePlatformTaskxcelmcoreTaskTaskxxad elmcorePlatformTaskxdelmcoreTaskTaskxxae elmcorePlatformTaskxeelmcoreTaskTaskxxaresult elmcorePlatformTaskxresultmapErroraxyxyelmcoreTaskTaskxxaa elmcorePlatformTaskxaelmcoreTaskTaskxyaa elmcorePlatformTaskyaonErroraxyxelmcoreTaskTaskxyaa elmcorePlatformTaskyaelmcoreTaskTaskxxaa elmcorePlatformTaskxaelmcoreTaskTaskxyaa elmcorePlatformTaskyaperformamsgamsgelmcoreTaskTaskxelmcoreBasicsNeveraa elmcorePlatformTaskelmcoreBasicsNeveraelmcore Platform.CmdCmdmsgsequenceaxelmcoreListListelmcoreTaskTaskxxaa elmcorePlatformTaskxaelmcoreTaskTaskxxaelmcoreListLista elmcorePlatformTaskxelmcoreListListasucceedaxaelmcoreTaskTaskxxaa elmcorePlatformTaskxaMyCmdmsgPerformelmcoreTaskTaskxelmcoreBasicsNeveramsg elmcorePlatformTaskxaTaskxa elmcorePlatformTaskxaelmcoreTuplefirstababamapBothabxyaxbyabxymapFirstabxaxabxb mapSecondabybyabaypairabababsecondababbelmcoreelmjsonelmcore -------------------------------------------------------------------------------- /src/Analyze/Diagnostics.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Analyze.Diagnostics 4 | ( ElmDiagnostics 5 | , run 6 | ) where 7 | 8 | import Control.Monad.Trans (liftIO) 9 | import Data.Aeson (FromJSON, (.:), (.:?)) 10 | import qualified Data.Aeson as A 11 | import qualified Data.Aeson.Types as ATypes 12 | import Data.Aeson.Types (Parser) 13 | import qualified Data.List as List 14 | import qualified Data.Maybe as Maybe 15 | import Data.Semigroup ((<>)) 16 | import Data.Text (Text) 17 | import qualified Data.Text as Text 18 | import qualified LSP.Log as Log 19 | import LSP.Data.Diagnostic (Diagnostic) 20 | import qualified LSP.Data.Diagnostic as D 21 | import LSP.Data.Range (Range) 22 | import qualified LSP.Data.Range as Range 23 | import qualified LSP.Data.Position as Position 24 | import Misc ((<|), (|>)) 25 | import qualified Misc 26 | import System.Exit as SysE 27 | import System.Process as SysP 28 | import Task (Task) 29 | import qualified Task 30 | 31 | -- DIAGNOSTICS MessageMeta -- 32 | data MessagePartMeta = 33 | MessageMeta 34 | { _bold :: Bool 35 | , _underLine :: Bool 36 | , _color :: Maybe Text 37 | , _string :: Text 38 | } 39 | deriving (Show) 40 | 41 | instance FromJSON MessagePartMeta where 42 | parseJSON = 43 | A.withObject "Diagnostic MessagePartMeta" $ \v -> 44 | return MessageMeta 45 | <*> v .: "bold" 46 | <*> v .: "underline" 47 | <*> v .:? "color" 48 | <*> v .: "string" 49 | 50 | -- DIAGNOSTICS Message 51 | data MessagePart 52 | = Str Text 53 | | Meta MessagePartMeta 54 | deriving (Show) 55 | 56 | instance FromJSON MessagePart where 57 | parseJSON value = 58 | case value of 59 | A.Object _ -> 60 | return Meta 61 | <*> A.parseJSON value 62 | 63 | A.String _ -> 64 | return Str 65 | <*> A.parseJSON value 66 | 67 | _ -> 68 | ATypes.typeMismatch "Diagnostic MessagePart" value 69 | 70 | messageToTextThrowAwayMeta :: MessagePart -> Text 71 | messageToTextThrowAwayMeta message = 72 | case message of 73 | Str text -> 74 | text 75 | 76 | Meta _meta -> 77 | "" 78 | 79 | messageToText :: MessagePart -> Text 80 | messageToText message = 81 | case message of 82 | Str text -> 83 | text 84 | 85 | Meta meta -> 86 | _string meta 87 | 88 | -- DIAGNOSTICS Problem -- 89 | data Problem = 90 | Problem 91 | { _title :: Text 92 | , _range :: Range 93 | , _message :: [MessagePart] 94 | } 95 | deriving (Show) 96 | 97 | instance FromJSON Problem where 98 | parseJSON = 99 | A.withObject "Diagnostic Problem" $ \v -> 100 | return Problem 101 | <*> v .: "title" 102 | <*> v .: "region" -- parse range as "region" 103 | <*> v .: "message" 104 | 105 | -- DIAGNOSTICS ERROR -- 106 | data Error = 107 | Error 108 | { _path :: Text 109 | , _name :: Text 110 | , _problems :: [Problem] 111 | } 112 | deriving (Show) 113 | 114 | instance FromJSON Error where 115 | parseJSON = 116 | A.withObject "Diagnostic Error" $ \v -> 117 | return Error 118 | <*> v .: "path" 119 | <*> v .: "name" 120 | <*> v .: "problems" 121 | 122 | -- DIAGNOSTICS RESULT -- 123 | data ElmDiagnostics 124 | = CompileError [Error] 125 | | OtherError Text Text [MessagePart] 126 | deriving (Show) 127 | 128 | instance FromJSON ElmDiagnostics where 129 | parseJSON = 130 | A.withObject "Diagnostic Error" $ \v -> 131 | (v .: "type" :: Parser Text) >>= \type_ -> 132 | case type_ of 133 | "compile-errors" -> 134 | return CompileError 135 | <*> v .: "errors" 136 | 137 | "error" -> 138 | return OtherError 139 | <*> v .: "path" 140 | <*> v .: "title" 141 | <*> v .: "message" 142 | 143 | _ -> 144 | fail "Invalid diagnostics result" 145 | 146 | -- CONVERT TO LSP DATA STRUCTURE 147 | squashConsecutiveChars :: Text -> Text 148 | squashConsecutiveChars text = 149 | text 150 | |> Text.unpack 151 | |> List.group 152 | |> List.foldl 153 | (\acc cur -> 154 | case cur of 155 | h0 : h1 : _ -> 156 | if (h0 == ' ' && h1 == ' ') || (h0 == '\n' && h1 == '\n') then 157 | Text.append acc (Text.singleton h0) 158 | 159 | else 160 | Text.append acc (Text.pack cur) 161 | 162 | _ -> 163 | Text.append acc (Text.pack cur) 164 | ) 165 | "" 166 | 167 | toDiagnostics :: Text -> ElmDiagnostics -> [(Text, [Diagnostic])] 168 | toDiagnostics filePath diagnostics = 169 | case diagnostics of 170 | CompileError errors -> 171 | List.map 172 | (\(Error path _name problems) -> 173 | ( path 174 | , List.map 175 | (\(Problem _title range message) -> 176 | D.Diagnostic 177 | -- LSP protocol uses 0-index line/column numbers and the Elm 178 | -- compiler does not. So we decrement each by 1 to get range properly 179 | (Range.updatePositions (\l -> l - 1) range) 180 | (List.foldl 181 | (\acc cur -> 182 | cur 183 | |> messageToTextThrowAwayMeta 184 | |> squashConsecutiveChars 185 | |> Text.append acc 186 | ) 187 | "" 188 | message 189 | ) 190 | 1 191 | ) 192 | problems 193 | ) 194 | ) 195 | errors 196 | 197 | OtherError path title messageParts -> 198 | -- If it's OtherError, that means the problem lies in `elm.json` or something 199 | -- so we show the issue at the top of whatever file is open 200 | [ ( filePath 201 | , [ D.Diagnostic 202 | (Range.Range (Position.Position (0, 0), Position.Position (0, 6))) 203 | (title <> " in " <> path <> ". " <> 204 | List.foldl 205 | (\acc cur -> 206 | cur 207 | |> messageToText 208 | |> squashConsecutiveChars 209 | |> Text.append acc 210 | ) 211 | "" 212 | messageParts 213 | ) 214 | 1 215 | ] 216 | ) 217 | ] 218 | 219 | -- RUN DIAGNOSTICS -- 220 | outputToDiagnostics :: Text -> (SysE.ExitCode, String, String) -> Either Text [Diagnostic] 221 | outputToDiagnostics filePath (exitCode, _stdOutString, stdErrString) = 222 | case exitCode of 223 | SysE.ExitFailure _ -> 224 | let 225 | eitherAllDiagnostics = 226 | stdErrString 227 | |> Text.pack 228 | |> Misc.textToByteString 229 | |> A.eitherDecode 230 | |> Misc.mapLeft Text.pack 231 | |> fmap (toDiagnostics filePath) 232 | in 233 | case eitherAllDiagnostics of 234 | Left error -> 235 | Left error 236 | 237 | -- elm make returns diagnostics on all files with errors so here 238 | -- we only take the diagnostics for the relevent file. If there are 239 | -- no relevent diagnostics, we clear current diagnostics 240 | Right allDiagnostics -> 241 | allDiagnostics 242 | |> List.find 243 | (\(pathForDiagnostics, _) -> 244 | filePath == pathForDiagnostics 245 | ) 246 | |> fmap snd 247 | |> Maybe.fromMaybe [] 248 | |> Right 249 | 250 | SysE.ExitSuccess -> 251 | Right [] 252 | 253 | run :: Text -> Text -> Task [Diagnostic] 254 | run elmExectuablePath filePath = 255 | do 256 | processOutput <- liftIO 257 | (SysP.readProcessWithExitCode 258 | (Text.unpack elmExectuablePath) 259 | ["make", Text.unpack filePath, "--report=json"] 260 | "" 261 | ) 262 | Task.liftEither (outputToDiagnostics filePath processOutput) 263 | -------------------------------------------------------------------------------- /src/Analyze/Search.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Analyze.Search 4 | ( hover 5 | , HoverResult(..) 6 | , getInfo 7 | , Location(..) 8 | , Value(..) 9 | , canTypeToText 10 | ) where 11 | 12 | 13 | import AST.Canonical (Module) 14 | import qualified AST.Canonical as Can 15 | import qualified AST.Module.Name as ModuleName 16 | import qualified Elm.Name as N 17 | import qualified Data.List as List 18 | import qualified Data.Foldable as Foldable 19 | import qualified Data.Map as Map 20 | import qualified Data.Maybe as Maybe 21 | import Data.Semigroup ((<>)) 22 | import Data.Text (Text) 23 | import qualified Data.Text as Text 24 | import qualified LSP.Misc 25 | import Misc (andThen, (|>), (<|)) 26 | import qualified Reporting.Annotation as A 27 | import qualified Reporting.Doc as D 28 | import qualified Reporting.Region as R 29 | import qualified Reporting.Render.Type.Localizer as L 30 | import qualified Reporting.Render.Type as RenderType 31 | import Task (Task) 32 | import qualified Type.Constrain.Module as Constrain 33 | import qualified Type.Type as Type 34 | import qualified Type.Solve as TypeSolver 35 | import qualified Type.UnionFind as UF 36 | import qualified Task 37 | 38 | 39 | -- Hover 40 | 41 | 42 | data HoverResult 43 | = HoverType Can.Type 44 | | HoverReference ModuleName.Canonical N.Name 45 | | HoverDebug String 46 | 47 | 48 | hover :: Module -> L.Localizer -> Int -> Int -> Task HoverResult 49 | hover modul localizer line column = 50 | let 51 | location = 52 | Location line column 53 | 54 | maybeInfo = 55 | getInfo modul location 56 | in 57 | case maybeInfo of 58 | Nothing -> 59 | Task.throw "Not found" 60 | 61 | Just info -> 62 | case info of 63 | Raw name -> 64 | -- TODO: Research tree for raw name? 65 | Task.throw ("The type of \"" <> N.toText name <> "\" could not be determined") 66 | 67 | DefinitionName definitionName -> 68 | do 69 | annotations <- LSP.Misc.getAnnotations modul 70 | annotations 71 | |> Map.lookup definitionName 72 | |> fmap (\(Can.Forall _freeVars tipe) -> return (HoverType tipe)) 73 | |> Maybe.fromMaybe (Task.throw "Definition name found, but not top level") 74 | 75 | InferredTopLevelArg functionName argNumber variableName -> 76 | do 77 | annotations <- LSP.Misc.getAnnotations modul 78 | let maybeArgType = 79 | annotations 80 | |> Map.lookup functionName 81 | |> andThen 82 | (\(Can.Forall _ tipe) -> 83 | getArgAtPosition argNumber tipe 84 | ) 85 | case maybeArgType of 86 | Nothing -> 87 | Task.throw "Inferred type not found" 88 | 89 | Just canType -> 90 | HoverType canType 91 | |> return 92 | 93 | 94 | Type variableName canType -> 95 | HoverType canType 96 | |> return 97 | 98 | Reference canonical name -> 99 | HoverReference canonical name 100 | |> return 101 | 102 | Debug message -> 103 | HoverDebug message 104 | |> return 105 | 106 | 107 | -- Base search 108 | 109 | 110 | data Value 111 | = Raw N.Name 112 | | DefinitionName N.Name 113 | | InferredTopLevelArg N.Name Int N.Name 114 | | Type (Maybe N.Name) Can.Type 115 | | Reference ModuleName.Canonical N.Name 116 | | Debug String 117 | 118 | 119 | data Location 120 | = Location {_row :: Int, _col :: Int} 121 | 122 | 123 | getInfo :: Module -> Location -> Maybe Value 124 | getInfo modul location = 125 | modul 126 | |> Can._decls 127 | |> foldlDelcs 128 | (\declaration maybeFound -> 129 | maybeFound 130 | |> ifNothingThen (searchDefinition location declaration) 131 | ) 132 | (\_recDeclarations maybeFound -> maybeFound) 133 | Nothing 134 | 135 | 136 | foldlDelcs :: (Can.Def -> result -> result) -> ([Can.Def] -> result -> result) -> result -> Can.Decls -> result 137 | foldlDelcs declareFunc recDeclareFunc acc decls = 138 | case decls of 139 | Can.Declare def subDecls -> 140 | foldlDelcs declareFunc recDeclareFunc (declareFunc def acc) subDecls 141 | 142 | Can.DeclareRec defs subDecls -> 143 | foldlDelcs declareFunc recDeclareFunc (recDeclareFunc defs acc) subDecls 144 | 145 | Can.SaveTheEnvironment -> 146 | acc 147 | 148 | 149 | searchDefinitions :: Location -> [Can.Def] -> Maybe Value 150 | searchDefinitions location definitions = 151 | List.foldl 152 | (\maybeFound definition -> 153 | maybeFound |> ifNothingThen (searchDefinition location definition) 154 | ) 155 | Nothing 156 | definitions 157 | 158 | 159 | searchDefinition :: Location -> Can.Def -> Maybe Value 160 | searchDefinition location definition = 161 | case definition of 162 | Can.Def locatedDefinition args expression -> 163 | let 164 | thisDefinition = 165 | locatedDefinition 166 | |> isWithin location 167 | |> fmap DefinitionName 168 | 169 | tryToGetRidOfRaw found = 170 | case found of 171 | Raw name -> 172 | args 173 | |> List.zip [1..] 174 | |> List.foldr 175 | (\(index, curPattern) acc -> 176 | acc 177 | |> ifNothingThen 178 | (searchUntypedPattern name 179 | (unboxLocated locatedDefinition) 180 | index 181 | curPattern 182 | ) 183 | ) 184 | Nothing 185 | |> ifNothingThen (Just found) 186 | 187 | _ -> 188 | Just found 189 | 190 | thisArgs = 191 | searchPatterns location args 192 | |> andThen tryToGetRidOfRaw 193 | 194 | thisExpression = 195 | searchExpression location expression 196 | |> andThen tryToGetRidOfRaw 197 | in 198 | thisDefinition 199 | |> ifNothingThen thisArgs 200 | |> ifNothingThen thisExpression 201 | 202 | Can.TypedDef locatedDefinition _typeVariables typedArgs expression resultType -> 203 | let 204 | thisDefinition = 205 | locatedDefinition 206 | |> isWithin location 207 | |> fmap 208 | (\name -> 209 | Type (Just name) 210 | (typedArgs 211 | |> List.map snd 212 | |> toFunction resultType 213 | ) 214 | ) 215 | 216 | tryToGetRidOfRaw found = 217 | case found of 218 | Raw name -> 219 | typedArgs 220 | |> List.foldr 221 | (\(curPattern, curType) acc -> 222 | acc |> ifNothingThen (searchTypedPattern name curPattern curType) 223 | ) 224 | Nothing 225 | |> ifNothingThen (Just found) 226 | 227 | _ -> 228 | Just found 229 | 230 | thisArgs = 231 | typedArgs 232 | |> List.map fst 233 | |> searchPatterns location 234 | |> andThen tryToGetRidOfRaw 235 | 236 | thisExpression = 237 | searchExpression location expression 238 | |> andThen tryToGetRidOfRaw 239 | in 240 | thisDefinition 241 | |> ifNothingThen thisArgs 242 | |> ifNothingThen thisExpression 243 | 244 | 245 | searchPatterns :: Location -> [Can.Pattern] -> Maybe Value 246 | searchPatterns location patterns = 247 | List.foldl 248 | (\maybeFound pattern -> 249 | maybeFound |> ifNothingThen (searchPattern location pattern) 250 | ) 251 | Nothing 252 | patterns 253 | 254 | 255 | searchPattern :: Location -> Can.Pattern -> Maybe Value 256 | searchPattern location locatedPattern = 257 | locatedPattern 258 | |> isWithin location 259 | |> andThen 260 | (\pattern -> 261 | case pattern of 262 | Can.PAlias locatedSubPattern name -> 263 | searchPattern location locatedSubPattern 264 | |> ifNothingThen (Just <| Raw name) 265 | 266 | Can.PTuple locatedLeftPattern locatedMiddlePattern maybeLocatedRightPattern -> 267 | searchPattern location locatedLeftPattern 268 | |> ifNothingThen (searchPattern location locatedMiddlePattern) 269 | |> ifNothingThen (maybeLocatedRightPattern |> andThen (searchPattern location)) 270 | 271 | Can.PList locatedPatterns -> 272 | searchPatterns location locatedPatterns 273 | 274 | Can.PCons locatedPatternA locatedPatternB -> 275 | searchPattern location locatedPatternA 276 | |> ifNothingThen (searchPattern location locatedPatternB) 277 | 278 | Can.PCtor {Can._p_home=canoncial, Can._p_type=typeName, Can._p_args=args} -> 279 | args 280 | |> List.foldr 281 | (\(Can.PatternCtorArg {Can._arg=arg, Can._type=tipe}) acc -> 282 | case acc of 283 | Nothing -> 284 | searchPattern location arg 285 | |> andThen 286 | (\found -> 287 | case found of 288 | Raw name -> 289 | Just (Type (Just name) tipe) 290 | 291 | _ -> 292 | Just found 293 | ) 294 | |> ifNothingThen 295 | (arg 296 | |> isWithin location 297 | |> fmap (\_ -> Type Nothing tipe) 298 | ) 299 | 300 | Just _ -> 301 | acc 302 | ) 303 | Nothing 304 | |> ifNothingThen (Just (Reference canoncial typeName)) 305 | 306 | Can.PUnit -> 307 | Just (Type Nothing unit) 308 | 309 | Can.PBool _ _ -> 310 | Just (Type Nothing bool) 311 | 312 | Can.PChr _ -> 313 | Just (Type Nothing char) 314 | 315 | Can.PStr _ -> 316 | Just (Type Nothing string) 317 | 318 | Can.PInt _ -> 319 | Just (Type Nothing int) 320 | 321 | Can.PVar name -> 322 | Just (Raw name) 323 | 324 | _ -> 325 | Nothing 326 | ) 327 | 328 | 329 | searchExpressions :: Location -> [Can.Expr] -> Maybe Value 330 | searchExpressions location expressions = 331 | List.foldl 332 | (\maybeFound expression -> 333 | maybeFound |> ifNothingThen (searchExpression location expression) 334 | ) 335 | Nothing 336 | expressions 337 | 338 | 339 | searchExpression :: Location -> Can.Expr -> Maybe Value 340 | searchExpression location locatedExpression = 341 | let 342 | searchSubExpression = 343 | searchExpression location 344 | 345 | searchSubExpressions = 346 | searchExpressions location 347 | in 348 | locatedExpression 349 | |> isWithin location 350 | |> andThen 351 | (\expression -> 352 | case expression of 353 | Can.VarLocal name -> 354 | Just <| Raw name 355 | 356 | Can.VarTopLevel canoncial name -> 357 | Just <| Reference canoncial name 358 | 359 | Can.VarForeign canoncial name _ -> 360 | Just <| Reference canoncial name 361 | 362 | Can.VarCtor _ canoncial name _ _ -> 363 | Just <| Reference canoncial name 364 | 365 | Can.VarDebug canoncial name _ -> 366 | Just <| Reference canoncial name 367 | 368 | Can.VarOperator name canoncial _ _ -> 369 | Just <| Reference canoncial name 370 | 371 | Can.Chr _ -> 372 | Just (Type Nothing char) 373 | 374 | Can.Str _ -> 375 | Just (Type Nothing string) 376 | 377 | Can.Int _ -> 378 | Just (Type Nothing int) 379 | 380 | Can.Float _ -> 381 | Just (Type Nothing float) 382 | 383 | Can.List locatedExpresions -> 384 | searchSubExpressions locatedExpresions 385 | 386 | Can.Negate subExpression -> 387 | searchSubExpression subExpression 388 | 389 | Can.Binop binopName canoncial _ _ subExpressionA subExpressionB -> 390 | searchSubExpression subExpressionA 391 | |> ifNothingThen (searchSubExpression subExpressionB) 392 | |> ifNothingThen (Just <| Reference canoncial binopName) 393 | 394 | Can.Lambda subPatterns expression -> 395 | searchSubExpression expression 396 | |> ifNothingThen (searchPatterns location subPatterns) 397 | 398 | Can.Call function args -> 399 | searchSubExpression function 400 | |> ifNothingThen (searchSubExpressions args) 401 | 402 | Can.If expressions result -> 403 | searchSubExpression result 404 | |> ifNothingThen 405 | (List.foldl 406 | (\maybeFound (expressionA, expressionB) -> 407 | maybeFound 408 | |> ifNothingThen (searchSubExpression expressionA) 409 | |> ifNothingThen (searchSubExpression expressionB) 410 | ) 411 | Nothing 412 | expressions 413 | ) 414 | 415 | Can.Let definition subExpression -> 416 | searchSubExpression subExpression 417 | |> ifNothingThen (searchDefinition location definition) 418 | 419 | Can.LetRec definitions subExpression -> 420 | searchSubExpression subExpression 421 | |> ifNothingThen (searchDefinitions location definitions) 422 | 423 | Can.LetDestruct pattern subExpressionA subExpressionB -> 424 | searchPattern location pattern 425 | |> ifNothingThen (searchSubExpression subExpressionA) 426 | |> ifNothingThen (searchSubExpression subExpressionB) 427 | 428 | Can.Case subExpression caseBranches -> 429 | searchSubExpression subExpression 430 | |> ifNothingThen (searchCaseBranches location caseBranches) 431 | 432 | Can.Accessor name -> 433 | Just (Raw name) 434 | 435 | Can.Access expresion locatedName -> 436 | locatedName 437 | |> isWithin location 438 | |> fmap Raw 439 | |> ifNothingThen (searchSubExpression expresion) 440 | 441 | Can.Update name expression fieldUpdates -> 442 | searchSubExpression expression 443 | |> ifNothingThen 444 | (fieldUpdates 445 | |> Map.toList 446 | |> List.foldl 447 | (\maybeFound (_ , Can.FieldUpdate region expression) -> 448 | maybeFound 449 | |> ifNothingThen 450 | (if location |> isWithinRegion region then 451 | searchSubExpression expression 452 | 453 | else 454 | Nothing 455 | ) 456 | ) 457 | Nothing 458 | 459 | ) 460 | |> ifNothingThen (Just <| Raw name) 461 | 462 | Can.Record map -> 463 | map 464 | |> Map.toList 465 | |> List.foldl 466 | (\maybeFound (_ , expression) -> 467 | maybeFound 468 | |> ifNothingThen (searchExpression location expression) 469 | ) 470 | Nothing 471 | 472 | Can.Unit -> 473 | Just (Type Nothing unit) 474 | 475 | Can.Tuple subExpressionA subExpressionB wrapperExpression-> 476 | searchSubExpression subExpressionA 477 | |> ifNothingThen (searchSubExpression subExpressionB) 478 | |> ifNothingThen (wrapperExpression |> andThen searchSubExpression) 479 | 480 | _ -> 481 | Nothing 482 | ) 483 | 484 | 485 | searchCaseBranches :: Location -> [Can.CaseBranch] -> Maybe Value 486 | searchCaseBranches location caseBranches = 487 | List.foldl 488 | (\maybeFound (Can.CaseBranch pattern expression) -> 489 | maybeFound 490 | |> ifNothingThen (searchPattern location pattern) 491 | |> ifNothingThen (searchExpression location expression) 492 | ) 493 | Nothing 494 | caseBranches 495 | 496 | 497 | -- Arguements flipped for pipeline operator 498 | ifNothingThen :: Maybe value -> Maybe value -> Maybe value 499 | ifNothingThen nextMaybe curMaybe = 500 | case curMaybe of 501 | Nothing -> 502 | nextMaybe 503 | 504 | Just _ -> 505 | curMaybe 506 | 507 | 508 | isWithin :: Location -> A.Located value -> Maybe value 509 | isWithin location (A.At region value) = 510 | if location |> isWithinRegion region then 511 | Just value 512 | 513 | else 514 | Nothing 515 | 516 | 517 | isWithinRegion :: R.Region -> Location -> Bool 518 | isWithinRegion (R.Region (R.Position startLine startCol) (R.Position endLine endCol)) (Location searchLine searchCol) = 519 | (searchLine >= startLine && searchCol >= startCol) 520 | && (searchLine <= endLine && searchCol <= endCol) 521 | 522 | 523 | unboxLocated :: A.Located value -> value 524 | unboxLocated (A.At _ value) = 525 | value 526 | 527 | 528 | -- Can Type helpers 529 | 530 | 531 | bool :: Can.Type 532 | bool = 533 | Can.TType ModuleName.basics N.bool [] 534 | 535 | 536 | char :: Can.Type 537 | char = 538 | Can.TType ModuleName.char N.char [] 539 | 540 | 541 | string :: Can.Type 542 | string = 543 | Can.TType ModuleName.string N.string [] 544 | 545 | 546 | int :: Can.Type 547 | int = 548 | Can.TType ModuleName.basics N.int [] 549 | 550 | 551 | float :: Can.Type 552 | float = 553 | Can.TType ModuleName.basics N.float [] 554 | 555 | 556 | unit :: Can.Type 557 | unit = 558 | Can.TUnit 559 | 560 | 561 | getArgAtPosition :: Int -> Can.Type -> Maybe Can.Type 562 | getArgAtPosition argNumber tipe = 563 | case tipe of 564 | Can.TLambda type1 type2 -> 565 | let 566 | nextArgNumber = 567 | argNumber - 1 568 | in 569 | if nextArgNumber == 0 then 570 | Just type1 571 | 572 | else 573 | getArgAtPosition nextArgNumber type2 574 | 575 | _ -> 576 | Nothing 577 | 578 | 579 | searchCanType :: N.Name -> Can.Type -> Maybe Can.Type 580 | searchCanType nameToSearchFor tipe = 581 | case tipe of 582 | Can.TLambda type1 type2 -> 583 | searchCanType nameToSearchFor type1 584 | |> ifNothingThen (searchCanType nameToSearchFor type2) 585 | 586 | Can.TVar name -> 587 | if nameToSearchFor == name then 588 | Just tipe 589 | 590 | else 591 | Nothing 592 | 593 | Can.TType _canonical name args -> 594 | if nameToSearchFor == name then 595 | Just tipe 596 | 597 | else 598 | args 599 | |> List.foldr 600 | (\cur acc -> 601 | case acc of 602 | Nothing -> 603 | searchCanType nameToSearchFor cur 604 | 605 | Just _ -> 606 | acc 607 | ) 608 | Nothing 609 | 610 | Can.TUnit -> 611 | Nothing 612 | 613 | Can.TTuple leftType midType maybeRightType -> 614 | searchCanType nameToSearchFor leftType 615 | |> ifNothingThen (searchCanType nameToSearchFor midType) 616 | |> ifNothingThen (maybeRightType |> andThen (searchCanType nameToSearchFor)) 617 | 618 | Can.TAlias canonical name typeMap _type -> 619 | if nameToSearchFor == name then 620 | Just tipe 621 | 622 | else 623 | typeMap 624 | |> List.foldr 625 | (\(subName, subType) acc -> 626 | if nameToSearchFor == subName then 627 | Just subType 628 | 629 | else 630 | searchCanType nameToSearchFor subType 631 | ) 632 | Nothing 633 | 634 | 635 | canTypeToText :: Can.Type -> Text 636 | canTypeToText tipe = 637 | canTypeToTextHelper False tipe "" 638 | 639 | 640 | canTypeToTextHelper :: Bool -> Can.Type -> Text -> Text 641 | canTypeToTextHelper wrapLambda tipe current = 642 | case tipe of 643 | Can.TLambda type1 type2 -> 644 | let 645 | firstPart = 646 | canTypeToTextHelper True type1 "" 647 | 648 | secondPart = 649 | canTypeToTextHelper False type2 "" 650 | in 651 | if wrapLambda then 652 | current <> "(" <> firstPart <> " -> " <> secondPart <> ")" 653 | 654 | else 655 | current <> firstPart <> " -> " <> secondPart 656 | 657 | Can.TVar name -> 658 | current <> N.toText name 659 | 660 | Can.TType canonical name args -> 661 | current <> N.toText name 662 | 663 | Can.TUnit -> 664 | current <> "()" 665 | 666 | Can.TTuple leftType midType maybeRightType -> 667 | current <> 668 | "( " 669 | <> canTypeToTextHelper True leftType "" 670 | <> ", " 671 | <> canTypeToTextHelper True midType "" 672 | <> (maybeRightType 673 | |> fmap 674 | (\rightType -> 675 | canTypeToTextHelper True rightType "" <> ", " 676 | ) 677 | |> Maybe.fromMaybe "" 678 | ) 679 | <> " )" 680 | 681 | Can.TAlias canonical name map type_ -> 682 | current <> N.toText name 683 | 684 | 685 | searchUntypedPattern :: N.Name -> N.Name -> Int -> Can.Pattern -> Maybe Value 686 | searchUntypedPattern name funcName argNumber pattern = 687 | case unboxLocated pattern of 688 | Can.PVar argName -> 689 | if argName == name then 690 | Just (InferredTopLevelArg funcName argNumber name) 691 | 692 | else 693 | Nothing 694 | 695 | Can.PCtor {Can._p_home=canoncial, Can._p_type=typeName, Can._p_name=ctorName, Can._p_args=args} -> 696 | if ctorName == name then 697 | Just (Reference canoncial typeName) 698 | 699 | else 700 | List.foldr 701 | (\(Can.PatternCtorArg {Can._arg=arg, Can._type=tipe}) acc -> 702 | case acc of 703 | Nothing -> 704 | case unboxLocated arg of 705 | Can.PVar argName -> 706 | if argName == name then 707 | Just (Type (Just name) tipe) 708 | 709 | else 710 | Nothing 711 | 712 | _ -> 713 | searchUntypedPattern name funcName argNumber arg 714 | 715 | Just _ -> 716 | acc 717 | ) 718 | Nothing 719 | args 720 | 721 | Can.PTuple leftPattern middlePattern maybeRightPattern -> 722 | let 723 | recurse = 724 | searchUntypedPattern name funcName argNumber 725 | in 726 | recurse leftPattern 727 | |> ifNothingThen (recurse middlePattern) 728 | |> ifNothingThen (maybeRightPattern |> andThen recurse) 729 | 730 | 731 | Can.PUnit -> 732 | Just (Type Nothing unit) 733 | 734 | Can.PBool _ _ -> 735 | Just (Type Nothing bool) 736 | 737 | Can.PChr _ -> 738 | Just (Type Nothing char) 739 | 740 | Can.PStr _ -> 741 | Just (Type Nothing string) 742 | 743 | Can.PInt _ -> 744 | Just (Type Nothing int) 745 | 746 | _ -> 747 | Nothing 748 | 749 | 750 | searchTypedPattern :: N.Name -> Can.Pattern -> Can.Type -> Maybe Value 751 | searchTypedPattern name pattern tipe = 752 | case (unboxLocated pattern, tipe) of 753 | (Can.PVar argName, _) -> 754 | if argName == name then 755 | Just (Type (Just name) tipe) 756 | 757 | else 758 | Nothing 759 | 760 | (Can.PCtor {Can._p_name=ctorName, Can._p_args=args}, tipe) -> 761 | if ctorName == name then 762 | Just (Type (Just name) tipe) 763 | 764 | else 765 | List.foldr 766 | (\(Can.PatternCtorArg {Can._arg=arg, Can._type=subTipe}) acc -> 767 | case acc of 768 | Nothing -> 769 | searchTypedPattern name arg subTipe 770 | 771 | Just _ -> 772 | acc 773 | ) 774 | Nothing 775 | args 776 | 777 | (Can.PTuple leftPattern midPattern maybeRightPattern, Can.TTuple leftType midType maybeRightType) -> 778 | searchTypedPattern name leftPattern leftType 779 | |> ifNothingThen (searchTypedPattern name midPattern midType) 780 | |> ifNothingThen 781 | (maybeRightPattern >>= \rightPattern -> 782 | maybeRightType >>= \rightType -> 783 | searchTypedPattern name rightPattern rightType 784 | ) 785 | 786 | 787 | (Can.PUnit, _) -> 788 | Just (Type Nothing unit) 789 | 790 | (Can.PBool _ _, _) -> 791 | Just (Type Nothing bool) 792 | 793 | (Can.PChr _, _) -> 794 | Just (Type Nothing char) 795 | 796 | (Can.PStr _, _) -> 797 | Just (Type Nothing string) 798 | 799 | (Can.PInt _, _) -> 800 | Just (Type Nothing int) 801 | 802 | _ -> 803 | Nothing 804 | 805 | 806 | toFunction :: Can.Type -> [Can.Type] -> Can.Type 807 | toFunction resultType args = 808 | case args of 809 | [] -> 810 | resultType 811 | 812 | head : rest -> 813 | Can.TLambda head (toFunction resultType rest) 814 | 815 | 816 | -- Constraint Type helpers 817 | 818 | 819 | searchConstraint :: [N.Name] -> Type.Constraint -> Task (Maybe N.Name) 820 | searchConstraint names constraint = 821 | case names of 822 | [] -> 823 | Nothing |> return 824 | 825 | nameToSearchFor : restOfNames -> 826 | case constraint of 827 | Type.CLocal _region localName _exptectedType -> 828 | if nameToSearchFor == localName then 829 | Just localName |> return 830 | 831 | else 832 | Nothing |> return 833 | 834 | Type.CLet {Type._header=header, Type._headerCon=headerCon, Type._bodyCon=bodyCon} -> 835 | case Map.lookup nameToSearchFor header of 836 | Nothing -> 837 | searchConstraint names bodyCon 838 | 839 | Just locatedTipe -> 840 | if List.null restOfNames then 841 | contraintTypeToName (unboxLocated locatedTipe) 842 | 843 | else 844 | searchConstraint restOfNames headerCon 845 | 846 | Type.CAnd subConstraints -> 847 | subConstraints 848 | |> Foldable.foldrM 849 | (\cur acc -> 850 | case acc of 851 | Nothing -> 852 | searchConstraint names cur 853 | 854 | Just _ -> 855 | acc |> return 856 | ) 857 | Nothing 858 | 859 | _ -> 860 | Nothing |> return 861 | 862 | 863 | contraintTypeToName :: Type.Type -> Task (Maybe N.Name) 864 | contraintTypeToName tipe = 865 | case tipe of 866 | Type.PlaceHolder name -> 867 | Just name 868 | |> return 869 | 870 | Type.VarN variable -> 871 | do 872 | (Type.Descriptor content _ _ _) <- Task.lift <| UF.get variable 873 | case content of 874 | Type.FlexVar name -> 875 | name 876 | |> Maybe.fromMaybe (N.fromText "a") 877 | |> Just 878 | |> return 879 | 880 | Type.FlexSuper _ name -> 881 | return name 882 | 883 | Type.RigidVar name -> 884 | return (Just name) 885 | 886 | Type.RigidSuper _ name -> 887 | return (Just name) 888 | 889 | _ -> 890 | return Nothing 891 | 892 | _ -> 893 | return Nothing 894 | 895 | 896 | -- Debug Helpers 897 | 898 | 899 | locationToString :: Location -> String 900 | locationToString (Location searchLine searchCol) = 901 | "(" ++ (show searchLine) ++ ", " ++ (show searchCol) ++ ")" 902 | 903 | 904 | locatedToString :: A.Located value -> String 905 | locatedToString (A.At (R.Region (R.Position startLine startCol) (R.Position endLine endCol)) value) = 906 | "Start: (" 907 | ++ (show startLine) 908 | ++ ", " 909 | ++ (show startCol) 910 | ++ ") End: (" 911 | ++ (show endLine) 912 | ++ ", " 913 | ++ (show endCol) 914 | ++ ")" 915 | -------------------------------------------------------------------------------- /src/LSP/Data/Capabilities.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module LSP.Data.Capabilities 4 | ( capabilities 5 | ) where 6 | 7 | import Data.Aeson (Value) 8 | import qualified Data.Aeson as A 9 | import qualified Data.ByteString.Lazy as BS 10 | 11 | capabilities :: Value 12 | capabilities = 13 | A.object 14 | [ ( "capabilities", A.object 15 | [ ("textDocumentSync", A.Number 1) 16 | , ("hoverProvider", A.Bool True) 17 | ] 18 | ) 19 | ] 20 | -------------------------------------------------------------------------------- /src/LSP/Data/Diagnostic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module LSP.Data.Diagnostic 4 | ( Diagnostic(..) 5 | ) where 6 | 7 | import Data.Aeson (ToJSON, FromJSON, Value, (.:), (.=), (.=), (.!=), (.:?)) 8 | import qualified Data.Aeson as A 9 | import Data.Text (Text) 10 | import LSP.Data.Range (Range) 11 | import LSP.Data.URI (URI) 12 | 13 | data Diagnostic = Diagnostic Range Text Int 14 | deriving (Show) 15 | 16 | instance FromJSON Diagnostic where 17 | parseJSON = 18 | A.withObject "Diagnostic" $ \v -> 19 | return Diagnostic 20 | <*> v .: "range" 21 | <*> v .: "message" 22 | <*> (v .:? "severity" .!= 1) 23 | 24 | instance ToJSON Diagnostic where 25 | toJSON (Diagnostic range message severity) = 26 | A.object 27 | [ "range" .= range 28 | , "message" .= message 29 | , "source" .= ("elm" :: Text) 30 | , "severity" .= severity 31 | ] 32 | -------------------------------------------------------------------------------- /src/LSP/Data/DocumentFilter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module LSP.Data.DocumentFilter 4 | ( DocumentFilter(..) 5 | ) where 6 | 7 | import Data.Aeson (FromJSON, ToJSON, Value, (.:?)) 8 | import qualified Data.Aeson as A 9 | import qualified Data.ByteString.Lazy as BS 10 | import Data.Text (Text) 11 | import qualified Misc 12 | 13 | newtype DocumentFilter = 14 | DocumentFilter (Maybe Text, Maybe Text, Maybe Text) 15 | 16 | instance FromJSON DocumentFilter where 17 | parseJSON = 18 | A.withObject "DocumentFilter" $ \v -> 19 | Misc.curryTriple DocumentFilter <$> v .:? "language" <*> v .:? "scheme" <*> 20 | v .:? "pattern" 21 | 22 | decode :: BS.ByteString -> Either String DocumentFilter 23 | decode = A.eitherDecode' 24 | -------------------------------------------------------------------------------- /src/LSP/Data/DocumentSelector.hs: -------------------------------------------------------------------------------- 1 | module LSP.Data.DocumentSelector 2 | ( DocumentSelector(..) 3 | ) where 4 | 5 | import Data.Aeson (FromJSON, ToJSON, Value, (.:?)) 6 | import qualified Data.Aeson as A 7 | import qualified Data.ByteString.Lazy as BS 8 | import LSP.Data.DocumentFilter (DocumentFilter) 9 | 10 | newtype DocumentSelector = 11 | DocumentSelector [DocumentFilter] 12 | 13 | instance FromJSON DocumentSelector where 14 | parseJSON v = DocumentSelector <$> A.parseJSON v 15 | 16 | decode :: BS.ByteString -> Either String DocumentSelector 17 | decode = A.eitherDecode' 18 | -------------------------------------------------------------------------------- /src/LSP/Data/Error.hs: -------------------------------------------------------------------------------- 1 | module LSP.Data.Error 2 | ( Error(..) 3 | ) where 4 | 5 | import Data.Aeson (Value) 6 | import qualified Data.Aeson as A 7 | import qualified Data.Aeson.Utils as AUtils 8 | import qualified Data.ByteString.Lazy as BS 9 | import Misc ((<|), (|>)) 10 | import qualified Misc 11 | 12 | data Error 13 | = ParseError 14 | | InvalidRequest 15 | | MethodNotFound 16 | | InvalidParams 17 | | InternalError 18 | | ServerErrorStart 19 | | ServerErrorEnd 20 | | ServerNotInitialized 21 | | UnknownErrorCode 22 | | RequestCancelled deriving (Show) 23 | 24 | fromCode :: Int -> Maybe Error 25 | fromCode err = 26 | case err of 27 | -32700 -> Just <| ParseError 28 | -32600 -> Just <| InvalidRequest 29 | -32601 -> Just <| MethodNotFound 30 | -32602 -> Just <| InvalidParams 31 | -32603 -> Just <| InternalError 32 | -32099 -> Just <| ServerErrorStart 33 | -32000 -> Just <| ServerErrorEnd 34 | -32002 -> Just <| ServerNotInitialized 35 | -32001 -> Just <| UnknownErrorCode 36 | -32800 -> Just <| RequestCancelled 37 | _ -> 38 | Nothing 39 | 40 | 41 | instance A.FromJSON Error where 42 | parseJSON = 43 | A.withScientific "Error" $ \num -> 44 | let int_ = num |> AUtils.floatingOrInteger |> Misc.toInt 45 | in case fromCode int_ of 46 | Nothing -> 47 | fail "invalid error" 48 | 49 | Just error -> 50 | return error 51 | 52 | toCode :: Error -> Int 53 | toCode err = 54 | case err of 55 | ParseError -> -32700 56 | InvalidRequest -> -32600 57 | MethodNotFound -> -32601 58 | InvalidParams -> -32602 59 | InternalError -> -32603 60 | ServerErrorStart -> -32099 61 | ServerErrorEnd -> -32000 62 | ServerNotInitialized -> -32002 63 | UnknownErrorCode -> -32001 64 | RequestCancelled -> -32800 65 | 66 | instance A.ToJSON Error where 67 | toJSON err = A.toJSON (toCode err) 68 | -------------------------------------------------------------------------------- /src/LSP/Data/FileChangeType.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module LSP.Data.FileChangeType 4 | ( FileChangeType(..) 5 | ) where 6 | 7 | import Data.Aeson (ToJSON, FromJSON, Value, (.:), (.:?), (.=)) 8 | import qualified Data.Aeson as A 9 | import qualified Data.Aeson.Utils as AUtils 10 | import Misc ((<|), (|>)) 11 | import qualified Misc 12 | 13 | data FileChangeType 14 | = Created 15 | | Changed 16 | | Deleted 17 | deriving (Show) 18 | 19 | instance FromJSON FileChangeType where 20 | parseJSON = 21 | A.withScientific "FileChangeType" $ \num -> 22 | let 23 | int_ = num |> AUtils.floatingOrInteger |> Misc.toInt 24 | in 25 | case int_ of 26 | 1 -> 27 | return Created 28 | 29 | 2 -> 30 | return Changed 31 | 32 | 3 -> 33 | return Deleted 34 | 35 | _ -> 36 | fail "Unrecognized file change type" 37 | 38 | instance ToJSON FileChangeType where 39 | toJSON fileChangeType = 40 | case fileChangeType of 41 | Created -> 42 | A.toJSON (1 :: Int) 43 | 44 | Changed -> 45 | A.toJSON (2 :: Int) 46 | 47 | Deleted -> 48 | A.toJSON (3 :: Int) 49 | -------------------------------------------------------------------------------- /src/LSP/Data/FileEvent.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module LSP.Data.FileEvent 4 | ( FileEvent(..) 5 | ) where 6 | 7 | import Data.Aeson (ToJSON, FromJSON, Value, (.:), (.:?), (.=)) 8 | import qualified Data.Aeson as A 9 | import Data.Text (Text) 10 | import Data.Aeson.Types (Parser, Pair) 11 | import LSP.Data.URI (URI) 12 | import LSP.Data.FileChangeType (FileChangeType) 13 | import Misc ((<|)) 14 | 15 | data FileEvent = 16 | FileEvent URI FileChangeType 17 | deriving (Show) 18 | 19 | instance FromJSON FileEvent where 20 | parseJSON = 21 | A.withObject "FileEvent" <| \v -> 22 | return FileEvent 23 | <*> v .: "uri" 24 | <*> v .: "type" 25 | 26 | instance ToJSON FileEvent where 27 | toJSON (FileEvent uri fileTypeChange) = 28 | A.object 29 | [ "uri" .= uri 30 | , "type" .= fileTypeChange 31 | ] 32 | 33 | -- CLIENT CAPABILITIES -- 34 | didChangeWatchedFiles :: Text 35 | didChangeWatchedFiles = "workspace/didChangeWatchedFiles" 36 | -------------------------------------------------------------------------------- /src/LSP/Data/FileSystemWatcher.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module LSP.Data.FileSystemWatcher 4 | ( FileSystemWatcher(..) 5 | ) where 6 | 7 | import Data.Aeson (ToJSON, FromJSON, Value, (.:), (.:?), (.=)) 8 | import qualified Data.Aeson as A 9 | import Data.Text (Text) 10 | import Data.Aeson.Types (Parser, Pair) 11 | import LSP.Data.URI (URI) 12 | import LSP.Data.FileChangeType (FileChangeType) 13 | import Misc ((<|)) 14 | 15 | data FileSystemWatcher = 16 | FileSystemWatcher Text (Maybe FileChangeType) 17 | deriving (Show) 18 | 19 | instance FromJSON FileSystemWatcher where 20 | parseJSON = 21 | A.withObject "FileSystemWatcher" <| \v -> 22 | return FileSystemWatcher 23 | <*> v .: "globPattern" 24 | <*> v .:? "kind" 25 | 26 | instance ToJSON FileSystemWatcher where 27 | toJSON (FileSystemWatcher glob kind) = 28 | A.object <| 29 | (("globPattern" .= glob) 30 | : (case kind of 31 | Nothing -> 32 | [] 33 | 34 | Just kind -> 35 | [ "kind" .= kind ] 36 | ) 37 | ) 38 | 39 | -- CLIENT CAPABILITIES -- 40 | didChangeWatchedFiles :: Text 41 | didChangeWatchedFiles = "workspace/didChangeWatchedFiles" 42 | -------------------------------------------------------------------------------- /src/LSP/Data/Header.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module LSP.Data.Header 4 | ( decodeEndLine 5 | , decode 6 | , encode 7 | ) where 8 | 9 | import qualified Data.ByteString.Lazy as BS 10 | import Data.Int (Int64) 11 | import Data.Semigroup ((<>)) 12 | import Data.Text (Text) 13 | import qualified Data.Text as Text 14 | import qualified Data.Text.Encoding as TextEncode 15 | import qualified Data.Text.Read as TextRead 16 | import Misc ((<|), (|>)) 17 | import qualified Misc 18 | 19 | 20 | intToByteString :: Int64 -> BS.ByteString 21 | intToByteString int_ = int_ |> show |> Text.pack |> Misc.textToByteString 22 | 23 | 24 | contentLengthHeader :: BS.ByteString 25 | contentLengthHeader = Misc.textToByteString "Content-Length: " 26 | 27 | 28 | contentLengthHeaderLength :: Int64 29 | contentLengthHeaderLength = BS.length contentLengthHeader 30 | 31 | 32 | incomingEndLine :: BS.ByteString 33 | incomingEndLine = 34 | let end = 35 | if Misc.isWindows 36 | then "\r\n" 37 | else "\r" 38 | in Misc.textToByteString end 39 | 40 | 41 | decodeEndLine :: BS.ByteString -> Either String () 42 | decodeEndLine string = 43 | if string == incomingEndLine 44 | then Right () 45 | else Left "Invalid end of line" 46 | 47 | 48 | toHeader :: BS.ByteString -> Either String Int 49 | toHeader bytestring = 50 | let stripped = BS.stripSuffix incomingEndLine bytestring 51 | either = Misc.maybeToEither "Invalid line ending" stripped 52 | in either >>= 53 | (\numString -> 54 | numString |> BS.toStrict |> TextEncode.decodeUtf8' |> 55 | Misc.mapLeft (const "Error reading Content-Length value")) >>= 56 | (\text -> 57 | fromIntegral . fst <$> 58 | (TextRead.decimal text :: Either String (Integer, Text))) 59 | 60 | 61 | decode :: BS.ByteString -> Either String Int 62 | decode string = 63 | let (header, rest) = BS.splitAt contentLengthHeaderLength string 64 | in if header == contentLengthHeader 65 | then toHeader rest 66 | else Left "Invalid header" 67 | 68 | 69 | outgoingEndLine :: BS.ByteString 70 | outgoingEndLine = 71 | let end = 72 | if Misc.isWindows 73 | then "\n\n" 74 | else "\r\n\r\n" 75 | in Misc.textToByteString end 76 | 77 | 78 | encode :: BS.ByteString -> BS.ByteString 79 | encode content = 80 | let contentLength = BS.length content 81 | in contentLengthHeader <> intToByteString contentLength <> outgoingEndLine 82 | -------------------------------------------------------------------------------- /src/LSP/Data/Location.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module LSP.Data.Location 4 | ( Location(..) 5 | , decode 6 | ) where 7 | 8 | import Data.Aeson (FromJSON, ToJSON, Value, (.:), (.=)) 9 | import qualified Data.Aeson as A 10 | import qualified Data.ByteString.Lazy as BS 11 | import Data.Text (Text) 12 | import LSP.Data.Range (Range) 13 | 14 | newtype Location = 15 | Location (Text, Range) 16 | 17 | instance FromJSON Location where 18 | parseJSON = 19 | A.withObject "Location" $ \v -> 20 | curry Location <$> v .: "uri" <*> v .: "range" 21 | 22 | decode :: BS.ByteString -> Either String Location 23 | decode = A.eitherDecode' 24 | 25 | instance ToJSON Location where 26 | toJSON (Location (uri, range)) = A.object ["uri" .= uri, "range" .= range] 27 | 28 | encode :: Location -> BS.ByteString 29 | encode = A.encode 30 | -------------------------------------------------------------------------------- /src/LSP/Data/Message.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module LSP.Data.Message 5 | ( Message(..) 6 | , decode 7 | , encode 8 | ) where 9 | 10 | import Control.Applicative ((<|>)) 11 | import Data.Aeson (FromJSON, ToJSON, Value, (.:), (.:!), (.=)) 12 | import qualified Data.Aeson as A 13 | import Data.Aeson.Types (Parser) 14 | import qualified Data.Aeson.Utils as AUtils 15 | import qualified Data.ByteString as BSStrict 16 | import qualified Data.ByteString.Lazy as BS 17 | import qualified Data.HashMap.Strict as HM 18 | import qualified Data.Maybe as Maybe 19 | import Data.Semigroup ((<>)) 20 | import Data.Text (Text) 21 | import qualified Data.Text as T 22 | import qualified LSP.Data.Header as Header 23 | import LSP.Data.MessageError (MessageError) 24 | import LSP.Data.NotificationMethod (NotificationMethod) 25 | import qualified LSP.Data.NotificationMethod as NotificationMethod 26 | import LSP.Data.RequestMethod (RequestMethod) 27 | import qualified LSP.Data.RequestMethod as RequestMethod 28 | import Misc ((|>)) 29 | import qualified Misc 30 | import System.IO (Handle) 31 | import qualified System.IO as IO 32 | 33 | data Message result 34 | = RequestMessage Text RequestMethod 35 | | NotificationMessage NotificationMethod 36 | | ResponseMessage (Maybe Text) (Maybe result) (Maybe MessageError) 37 | deriving (Show) 38 | 39 | -- DECODING -- 40 | 41 | jsonrpcDecoder :: HM.HashMap Text Value -> Parser Text 42 | jsonrpcDecoder v = v .: "jsonrpc" 43 | 44 | withJsonRcp :: HM.HashMap Text Value -> (HM.HashMap Text Value -> Parser (Message result)) -> Parser (Message result) 45 | withJsonRcp v finish = 46 | jsonrpcDecoder v >>= \case 47 | "2.0" -> 48 | finish v 49 | 50 | _ -> 51 | fail "\"jsonrpc\" must be \"2.0\"" 52 | 53 | requestMessageDecoder :: FromJSON result => HM.HashMap Text Value -> Parser (Message result) 54 | requestMessageDecoder v = 55 | let id = HM.lookup "id" v 56 | in case id of 57 | Just (A.String text) -> 58 | RequestMessage text <$> A.parseJSON (A.Object v) 59 | 60 | Just (A.Number num) -> 61 | RequestMessage 62 | (num |> AUtils.floatingOrInteger |> Misc.toInt |> show |> T.pack) <$> 63 | A.parseJSON (A.Object v) 64 | 65 | Just _ -> 66 | fail "\"id\" must be string or number" 67 | 68 | Nothing -> 69 | fail "\"id\" is required for a request message" 70 | 71 | notificationMessageDecoder :: FromJSON result => HM.HashMap Text Value -> Parser (Message result) 72 | notificationMessageDecoder v = 73 | NotificationMessage <$> A.parseJSON (A.Object v) 74 | 75 | responseMessageDecoder :: FromJSON result => HM.HashMap Text Value -> Parser (Message result) 76 | responseMessageDecoder v = 77 | let id = HM.lookup "id" v 78 | finish maybeId = 79 | ResponseMessage maybeId <$> v .:! "result" <*> v .:! "error" 80 | in case id of 81 | Just (A.String text) -> 82 | finish (Just text) 83 | 84 | Just (A.Number num) -> 85 | finish (Just (num |> AUtils.floatingOrInteger |> Misc.toInt |> show |> T.pack)) 86 | 87 | Just A.Null -> 88 | finish Nothing 89 | 90 | _ -> 91 | fail "\"id\" must be string, number or null" 92 | 93 | 94 | instance FromJSON result => FromJSON (Message result) where 95 | parseJSON = 96 | A.withObject "Incoming Message" $ \v -> 97 | withJsonRcp v requestMessageDecoder 98 | <|> withJsonRcp v notificationMessageDecoder 99 | <|> responseMessageDecoder v 100 | 101 | decode :: Handle -> IO (Either String (Message Value)) 102 | decode handle = 103 | getLineBSLazy >>= \header -> 104 | getLineBSLazy >>= \endLine -> 105 | let eitherContentLength = 106 | Header.decode header >>= \contentLength -> 107 | Header.decodeEndLine endLine >> return contentLength 108 | in case eitherContentLength of 109 | Left error -> 110 | return (Left error) 111 | 112 | Right contentLength -> 113 | BS.hGet IO.stdin contentLength >>= \json -> 114 | return (A.eitherDecode' json) 115 | 116 | getLineBSLazy :: IO BS.ByteString 117 | getLineBSLazy = BS.fromStrict <$> BSStrict.getLine 118 | 119 | -- ENCODING -- 120 | -- 121 | encodeJsonrpc :: (Text, Value) 122 | encodeJsonrpc = "jsonrpc" .= ("2.0" :: Text) 123 | 124 | encodeId :: Maybe Text -> (Text, Value) 125 | encodeId id = 126 | case id of 127 | Just value -> "id" .= id 128 | Nothing -> ("id", A.Null) 129 | 130 | encodeResult :: ToJSON result => result -> [(Text, Value)] 131 | encodeResult result = ["result" .= result] 132 | 133 | encodeError :: MessageError -> [(Text, Value)] 134 | encodeError error = ["error" .= error] 135 | 136 | encodeRequestMessage :: Text -> RequestMethod -> Value 137 | encodeRequestMessage id method = 138 | let pairs = RequestMethod.toPairs method 139 | in A.object ([ "id" .= id , encodeJsonrpc ] ++ pairs) 140 | 141 | encodeNotificationMessage :: NotificationMethod -> Value 142 | encodeNotificationMessage method = 143 | let pairs = NotificationMethod.toPairs method 144 | in A.object (encodeJsonrpc : pairs) 145 | 146 | encodeResponseMessage :: ToJSON result => Maybe Text -> Maybe result -> Maybe MessageError -> Value 147 | encodeResponseMessage maybeId maybeResult maybeError = 148 | let id = maybeId |> encodeId 149 | result = maybeResult |> fmap encodeResult |> Maybe.fromMaybe [] 150 | error = maybeError |> fmap encodeError |> Maybe.fromMaybe [] 151 | in A.object ([ id, encodeJsonrpc ] ++ result ++ error) 152 | 153 | instance ToJSON result => ToJSON (Message result) where 154 | toJSON message = 155 | case message of 156 | RequestMessage id method -> 157 | encodeRequestMessage id method 158 | 159 | NotificationMessage method -> 160 | encodeNotificationMessage method 161 | 162 | ResponseMessage maybeId maybeResult maybeError -> 163 | encodeResponseMessage maybeId maybeResult maybeError 164 | 165 | 166 | encode :: ToJSON result => Message result -> BS.ByteString 167 | encode outgoingMessage = 168 | let content = A.encode outgoingMessage 169 | in Header.encode content <> content 170 | -------------------------------------------------------------------------------- /src/LSP/Data/MessageError.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module LSP.Data.MessageError 4 | ( MessageError(..) 5 | ) where 6 | 7 | import Data.Aeson (Value, (.:), (.=)) 8 | import qualified Data.Aeson as A 9 | import qualified Data.ByteString.Lazy as BS 10 | import Data.Text (Text) 11 | import LSP.Data.Error (Error) 12 | 13 | data MessageError = 14 | MessageError Error Text 15 | deriving (Show) 16 | 17 | instance A.ToJSON MessageError where 18 | toJSON (MessageError err message) = 19 | A.object ["code" .= err, "message" .= message] 20 | 21 | instance A.FromJSON MessageError where 22 | parseJSON = 23 | A.withObject "Message Error" $ \v -> 24 | MessageError <$> v .: "code" <*> v .: "message" 25 | -------------------------------------------------------------------------------- /src/LSP/Data/NotificationMethod.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module LSP.Data.NotificationMethod 4 | ( NotificationMethod(..) 5 | , TextDocumentDidOpenParams(..) 6 | , PublishDiagnosticsParams(..) 7 | , ContentChange(..) 8 | , TextDocumentDidChangeParams(..) 9 | , TextDocumentDidSaveParams(..) 10 | , RegisterCapabilityParams(..) 11 | , DidChangeWatchedFilesParams(..) 12 | , MessageType(..) 13 | , ShowMessageParams(..) 14 | , toPairs 15 | ) where 16 | 17 | import Data.Aeson (ToJSON, FromJSON, Value, (.:), (.:?), (.=)) 18 | import qualified Data.Aeson as A 19 | import Data.Aeson.Types (Parser, Pair) 20 | import qualified Data.Aeson.Utils as AUtils 21 | import qualified Data.ByteString.Lazy as BS 22 | import qualified Data.HashMap.Strict as HM 23 | import Data.Text (Text) 24 | import LSP.Data.FileEvent (FileEvent) 25 | import LSP.Data.URI (URI) 26 | import LSP.Data.Range (Range) 27 | import LSP.Data.Diagnostic (Diagnostic) 28 | import LSP.Data.Registration (Registration) 29 | import Misc ((<|), (|>)) 30 | import qualified Misc 31 | 32 | -- INITIALIZED -- 33 | initialized :: Text 34 | initialized = "initialized" 35 | 36 | -- TEXT DOCUMENT DID OPEN -- 37 | textDocumentDidOpen :: Text 38 | textDocumentDidOpen = "textDocument/didOpen" 39 | 40 | newtype TextDocumentDidOpenParams = 41 | TextDocumentDidOpenParams (URI, Int, Text) 42 | deriving (Show) 43 | 44 | instance FromJSON TextDocumentDidOpenParams where 45 | parseJSON = 46 | A.withObject "TextDocumentDidOpenParams" <| \v -> 47 | v .: "textDocument" >>= \subV -> 48 | Misc.curryTriple TextDocumentDidOpenParams <$> subV .: "uri" <*> 49 | subV .: "version" <*> 50 | subV .: "text" 51 | 52 | -- TEXT DOCUMENT DID CHANGE -- 53 | newtype ContentChange = 54 | ContentChange Text 55 | deriving (Show) 56 | 57 | instance FromJSON ContentChange where 58 | parseJSON = 59 | A.withObject "ContentChange" <| \v -> fmap ContentChange (v .: "text") 60 | 61 | textDocumentDidChange :: Text 62 | textDocumentDidChange = "textDocument/didChange" 63 | 64 | newtype TextDocumentDidChangeParams = 65 | TextDocumentDidChangeParams (URI, Int, [ContentChange]) 66 | deriving (Show) 67 | 68 | instance FromJSON TextDocumentDidChangeParams where 69 | parseJSON = 70 | A.withObject "TextDocumentDidChangeParams" <| \v -> 71 | let applied = 72 | v .: "textDocument" >>= \subV -> 73 | return (Misc.curryTriple TextDocumentDidChangeParams) 74 | <*> subV .: "uri" 75 | <*> subV .: "version" 76 | in 77 | applied 78 | <*> v .: "contentChanges" 79 | 80 | -- TEXT DOCUMENT DID SAVE -- 81 | textDocumentDidSave :: Text 82 | textDocumentDidSave = "textDocument/didSave" 83 | 84 | newtype TextDocumentDidSaveParams = 85 | TextDocumentDidSaveParams URI 86 | deriving (Show) 87 | 88 | instance FromJSON TextDocumentDidSaveParams where 89 | parseJSON = 90 | A.withObject "TextDocumentDidSaveParams" <| \v -> 91 | v .: "textDocument" >>= \subV -> 92 | return TextDocumentDidSaveParams 93 | <*> subV .: "uri" 94 | 95 | 96 | -- PUBLISH DIAGNOSTICS -- 97 | publishDiagnostics:: Text 98 | publishDiagnostics = "textDocument/publishDiagnostics" 99 | 100 | newtype PublishDiagnosticsParams = 101 | PublishDiagnosticsParams (URI, [Diagnostic]) 102 | deriving (Show) 103 | 104 | instance FromJSON PublishDiagnosticsParams where 105 | parseJSON = 106 | A.withObject "PublishDiagnosticsParams" <| \v -> 107 | return (curry PublishDiagnosticsParams) 108 | <*> v .: "uri" 109 | <*> v .: "diagnostics" 110 | 111 | instance ToJSON PublishDiagnosticsParams where 112 | toJSON (PublishDiagnosticsParams (uri, diagnostics)) = 113 | A.object 114 | [ "uri" .= uri 115 | , "diagnostics" .= diagnostics 116 | ] 117 | 118 | 119 | -- REGISTER CAPABILITY -- 120 | registerCapability:: Text 121 | registerCapability = "client/registerCapability" 122 | 123 | newtype RegisterCapabilityParams = 124 | RegisterCapabilityParams [Registration] 125 | deriving (Show) 126 | 127 | instance FromJSON RegisterCapabilityParams where 128 | parseJSON = 129 | A.withObject "RegisterCapabilityParams" <| \v -> 130 | return RegisterCapabilityParams 131 | <*> v .: "registrations" 132 | 133 | instance ToJSON RegisterCapabilityParams where 134 | toJSON (RegisterCapabilityParams registrations) = 135 | A.object 136 | [ "registrations" .= registrations 137 | ] 138 | 139 | 140 | -- DID CHANGE WATCHED FILES 141 | didChangeWatchedFiles :: Text 142 | didChangeWatchedFiles = "workspace/didChangeWatchedFiles" 143 | 144 | 145 | newtype DidChangeWatchedFilesParams = 146 | DidChangeWatchedFilesParams [FileEvent] 147 | deriving (Show) 148 | 149 | instance FromJSON DidChangeWatchedFilesParams where 150 | parseJSON = 151 | A.withObject "DidChangeWatchedFilesParams" <| \v -> 152 | return DidChangeWatchedFilesParams 153 | <*> v .: "changes" 154 | 155 | instance ToJSON DidChangeWatchedFilesParams where 156 | toJSON (DidChangeWatchedFilesParams fileEvents) = 157 | A.object [ "changes" .= fileEvents ] 158 | 159 | 160 | -- WINDOW SHOW MESSAGE 161 | showMessage :: Text 162 | showMessage = "window/showMessage" 163 | 164 | 165 | data MessageType 166 | = Error 167 | | Warning 168 | | Info 169 | | Log 170 | deriving (Show) 171 | 172 | 173 | instance FromJSON MessageType where 174 | parseJSON = 175 | A.withScientific "MessageType" $ \num -> 176 | let 177 | int_ = num |> AUtils.floatingOrInteger |> Misc.toInt 178 | in 179 | case int_ of 180 | 1 -> 181 | return Error 182 | 183 | 2 -> 184 | return Warning 185 | 186 | 3 -> 187 | return Info 188 | 189 | 4 -> 190 | return Log 191 | 192 | _ -> 193 | fail "Unrecognized file change type" 194 | 195 | 196 | instance ToJSON MessageType where 197 | toJSON messageType = 198 | let 199 | int_ = 200 | case messageType of 201 | Error -> 202 | 1 203 | 204 | Warning -> 205 | 2 206 | 207 | Info -> 208 | 3 209 | 210 | Log -> 211 | 4 212 | in 213 | A.Number int_ 214 | 215 | 216 | data ShowMessageParams = 217 | ShowMessageParams MessageType Text 218 | deriving (Show) 219 | 220 | 221 | instance FromJSON ShowMessageParams where 222 | parseJSON = 223 | A.withObject "ShowMessageParams" <| \v -> 224 | return ShowMessageParams 225 | <*> v .: "type" 226 | <*> v .: "message" 227 | 228 | 229 | instance ToJSON ShowMessageParams where 230 | toJSON (ShowMessageParams type_ message) = 231 | A.object 232 | [ "type" .= type_ 233 | , "message" .= message 234 | ] 235 | 236 | 237 | -- EXIT -- 238 | exit :: Text 239 | exit = "exit" 240 | 241 | 242 | -- METHODS -- 243 | data NotificationMethod 244 | = Initialized 245 | | TextDocumentDidOpen TextDocumentDidOpenParams 246 | | PublishDiagnostics PublishDiagnosticsParams 247 | | TextDocumentDidChange TextDocumentDidChangeParams 248 | | TextDocumentDidSave TextDocumentDidSaveParams 249 | | RegisterCapability RegisterCapabilityParams 250 | | DidChangeWatchedFiles DidChangeWatchedFilesParams 251 | | ShowMessage ShowMessageParams 252 | | Exit 253 | deriving (Show) 254 | 255 | decoder :: HM.HashMap Text Value -> Text -> Parser NotificationMethod 256 | decoder v key 257 | | key == initialized = return Initialized 258 | | key == textDocumentDidOpen = TextDocumentDidOpen <$> v .: "params" 259 | | key == publishDiagnostics = PublishDiagnostics <$> v .: "params" 260 | | key == textDocumentDidChange = TextDocumentDidChange <$> v .: "params" 261 | | key == textDocumentDidSave = TextDocumentDidSave <$> v .: "params" 262 | | key == registerCapability = RegisterCapability <$> v .: "params" 263 | | key == didChangeWatchedFiles = DidChangeWatchedFiles <$> v .: "params" 264 | | key == showMessage = ShowMessage <$> v .: "params" 265 | | key == exit = return Exit 266 | | otherwise = fail "Unknown notificaiton method" 267 | 268 | instance FromJSON NotificationMethod where 269 | parseJSON = 270 | A.withObject "NotificationMethod" <| \v -> v .: "method" >>= decoder v 271 | 272 | toPairs :: NotificationMethod -> [Pair] 273 | toPairs message = 274 | case message of 275 | Initialized -> 276 | [ "method" .= initialized ] 277 | 278 | TextDocumentDidOpen _ -> 279 | [ "method" .= textDocumentDidOpen ] 280 | 281 | PublishDiagnostics params -> 282 | [ "method" .= publishDiagnostics 283 | , "params" .= params 284 | ] 285 | 286 | TextDocumentDidChange _ -> 287 | [ "method" .= textDocumentDidChange ] 288 | 289 | TextDocumentDidSave _ -> 290 | [ "method" .= textDocumentDidSave ] 291 | 292 | RegisterCapability params -> 293 | [ "method" .= registerCapability 294 | , "params" .= params 295 | ] 296 | 297 | DidChangeWatchedFiles params -> 298 | [ "method" .= registerCapability 299 | , "params" .= params 300 | ] 301 | 302 | ShowMessage params -> 303 | [ "method" .= showMessage 304 | , "params" .= params 305 | ] 306 | 307 | Exit -> 308 | [ "method" .= exit ] 309 | -------------------------------------------------------------------------------- /src/LSP/Data/Position.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module LSP.Data.Position 4 | ( Position(..) 5 | ) where 6 | 7 | import Control.Applicative ((<|>)) 8 | import Data.Aeson (FromJSON, ToJSON, Value, (.:), (.=)) 9 | import qualified Data.Aeson as A 10 | import qualified Data.ByteString.Lazy as BS 11 | 12 | newtype Position = 13 | Position (Int, Int) 14 | deriving (Show) 15 | 16 | instance FromJSON Position where 17 | parseJSON = 18 | A.withObject "Position" $ \v -> 19 | (curry Position <$> v .: "line" <*> v .: "character") 20 | <|> (curry Position <$> v .: "line" <*> v .: "column") 21 | 22 | instance ToJSON Position where 23 | toJSON (Position (line, character)) = 24 | A.object ["line" .= line, "character" .= character] 25 | -------------------------------------------------------------------------------- /src/LSP/Data/Range.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module LSP.Data.Range 4 | ( Range(..) 5 | , updatePositions 6 | ) where 7 | 8 | import Data.Aeson (FromJSON, ToJSON, Value, (.:), (.=)) 9 | import qualified Data.Aeson as A 10 | import qualified Data.ByteString.Lazy as BS 11 | import LSP.Data.Position (Position) 12 | import qualified LSP.Data.Position as P 13 | 14 | newtype Range = 15 | Range (Position, Position) 16 | deriving (Show) 17 | 18 | instance FromJSON Range where 19 | parseJSON = 20 | A.withObject "Range" $ \v -> curry Range <$> v .: "start" <*> v .: "end" 21 | 22 | instance ToJSON Range where 23 | toJSON (Range (start, end)) = A.object ["start" .= start, "end" .= end] 24 | 25 | updatePositions :: (Int -> Int) -> Range -> Range 26 | updatePositions func (Range (P.Position (l1, c1), P.Position (l2, c2))) = 27 | Range (P.Position (func l1, func c1), P.Position (func l2, func c2)) 28 | -------------------------------------------------------------------------------- /src/LSP/Data/Registration.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module LSP.Data.Registration 4 | ( Registration(..) 5 | ) where 6 | 7 | import Data.Aeson (ToJSON, FromJSON, Value, (.:), (.:?), (.=)) 8 | import Data.Aeson.Types (Parser) 9 | import qualified Data.Aeson as A 10 | import qualified Data.HashMap.Strict as HM 11 | import Data.Text (Text) 12 | import LSP.Data.FileSystemWatcher (FileSystemWatcher) 13 | import Misc ((<|)) 14 | 15 | 16 | data Registration 17 | = DidChangeWatchedFiles Text [FileSystemWatcher] 18 | deriving (Show) 19 | 20 | didChangeWatchedFiles :: Text 21 | didChangeWatchedFiles = "workspace/didChangeWatchedFiles" 22 | 23 | parseRegistration :: HM.HashMap Text Value -> Text -> Parser Registration 24 | parseRegistration v method 25 | | method == didChangeWatchedFiles = 26 | return DidChangeWatchedFiles 27 | <*> v .: "id" 28 | <*> v .: "watchers" 29 | 30 | instance FromJSON Registration where 31 | parseJSON = 32 | A.withObject "Registration" <| \v -> v .: "method" >>= parseRegistration v 33 | 34 | instance ToJSON Registration where 35 | toJSON registrationMethod = 36 | case registrationMethod of 37 | DidChangeWatchedFiles id fileSystemWatchers -> 38 | A.object 39 | [ "id" .= id 40 | , "method" .= (didChangeWatchedFiles :: Text) 41 | , "registerOptions" .= 42 | A.object [ "watchers" .= fileSystemWatchers ] 43 | ] 44 | -------------------------------------------------------------------------------- /src/LSP/Data/RequestMethod.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module LSP.Data.RequestMethod 4 | ( InitializeParams(..) 5 | , TextDocumentHoverParams(..) 6 | , RequestMethod(..) 7 | , toPairs 8 | ) where 9 | 10 | import Data.Aeson (FromJSON, Value, (.:), (.=)) 11 | import qualified Data.Aeson as A 12 | import Data.Aeson.Types (Parser, Pair) 13 | import qualified Data.HashMap.Strict as HM 14 | import Data.Text (Text) 15 | import LSP.Data.Position (Position) 16 | import LSP.Data.TextDocumentIdentifier (TextDocumentIdentifier) 17 | import LSP.Data.URI (URI) 18 | import Misc ((<|)) 19 | 20 | -- INITIALIZE -- 21 | initialize :: Text 22 | initialize = "initialize" 23 | 24 | newtype InitializeParams = 25 | InitializeParams URI 26 | deriving (Show) 27 | 28 | instance FromJSON InitializeParams where 29 | parseJSON = 30 | A.withObject "InitializeParams" <| \v -> InitializeParams <$> v .: "rootUri" 31 | 32 | -- TEXT DOCUMENT HOVER -- 33 | textDocumentHover :: Text 34 | textDocumentHover = "textDocument/hover" 35 | 36 | newtype TextDocumentHoverParams = 37 | TextDocumentHoverParams (URI, Position) 38 | deriving (Show) 39 | 40 | instance FromJSON TextDocumentHoverParams where 41 | parseJSON = 42 | A.withObject "TextDocumentHoverParams" <| \v -> 43 | return (curry TextDocumentHoverParams) 44 | <*> (v .: "textDocument" >>= \subV -> subV .: "uri") 45 | <*> v .: "position" 46 | 47 | -- SHUTDOWN -- 48 | shutdown :: Text 49 | shutdown = "shutdown" 50 | 51 | -- METHODS -- 52 | data RequestMethod 53 | = Initialize InitializeParams 54 | | TextDocumentHover TextDocumentHoverParams 55 | | Shutdown 56 | deriving (Show) 57 | 58 | decoder :: HM.HashMap Text Value -> Text -> Parser RequestMethod 59 | decoder v key 60 | | key == initialize = Initialize <$> v .: "params" 61 | | key == shutdown = return Shutdown 62 | | otherwise = fail "Unknown request method" 63 | 64 | instance FromJSON RequestMethod where 65 | parseJSON = A.withObject "RequestMethod" <| \v -> v .: "method" >>= decoder v 66 | 67 | toPairs :: RequestMethod -> [Pair] 68 | toPairs message = 69 | case message of 70 | Initialize _ -> 71 | [ "method" .= initialize ] 72 | 73 | TextDocumentHover _ -> 74 | [ "method" .= textDocumentHover ] 75 | 76 | Shutdown -> 77 | [ "method" .= shutdown ] 78 | -------------------------------------------------------------------------------- /src/LSP/Data/TextDocumentIdentifier.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module LSP.Data.TextDocumentIdentifier 4 | ( TextDocumentIdentifier(..) 5 | , decode 6 | ) where 7 | 8 | import Data.Aeson (FromJSON, Value, (.:)) 9 | import qualified Data.Aeson as A 10 | import qualified Data.ByteString.Lazy as BS 11 | import Data.Text (Text) 12 | import Misc ((<|)) 13 | 14 | newtype TextDocumentIdentifier = 15 | TextDocumentIdentifier Text 16 | deriving (Show) 17 | 18 | instance FromJSON TextDocumentIdentifier where 19 | parseJSON = 20 | A.withObject "TextDocumentIdentifier" <| \v -> 21 | TextDocumentIdentifier <$> v .: "uri" 22 | 23 | decode :: BS.ByteString -> Either String TextDocumentIdentifier 24 | decode = A.eitherDecode' 25 | -------------------------------------------------------------------------------- /src/LSP/Data/URI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | 4 | module LSP.Data.URI 5 | ( URI(..) 6 | , decodePath 7 | ) where 8 | 9 | 10 | import Data.Semigroup ((<>)) 11 | import qualified Data.Aeson as A 12 | import Data.Aeson.Types (ToJSON, FromJSON) 13 | import Data.Text (Text) 14 | import qualified Data.Text as Text 15 | import Data.Hashable as H 16 | import Misc ((<|)) 17 | 18 | 19 | newtype URI = 20 | URI Text 21 | deriving (Show, Eq, Ord, H.Hashable) 22 | 23 | 24 | prefix :: Text 25 | prefix = "file://" 26 | 27 | 28 | prefixLength :: Int 29 | prefixLength = Text.length prefix 30 | 31 | 32 | decodePath :: Text -> Either String Text 33 | decodePath uri = 34 | let (head, rest) = Text.splitAt prefixLength uri 35 | in if head == prefix 36 | then Right rest 37 | else Left "Invalid URI" 38 | 39 | 40 | instance FromJSON URI where 41 | parseJSON = 42 | A.withText "URI" <| \uri -> 43 | case decodePath uri of 44 | Left message -> 45 | fail message 46 | 47 | Right decoded -> 48 | return (URI decoded) 49 | 50 | 51 | instance ToJSON URI where 52 | toJSON (URI uri) = 53 | A.toJSON (prefix <> uri) 54 | -------------------------------------------------------------------------------- /src/LSP/Log.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module LSP.Log 4 | ( logger 5 | ) where 6 | 7 | import qualified Data.Text as Text 8 | import qualified System.Directory as Dir 9 | import qualified System.IO as IO 10 | 11 | logger :: Show a => a -> IO () 12 | logger message = 13 | let 14 | dirPath = 15 | "./elm-stuff/.lsp" 16 | 17 | filePath = 18 | Text.append dirPath "/debug.log" 19 | in 20 | Dir.createDirectoryIfMissing True (Text.unpack dirPath) >> 21 | IO.openFile (Text.unpack filePath) IO.AppendMode >>= \handle -> 22 | IO.hPrint handle message >> IO.hClose handle 23 | -------------------------------------------------------------------------------- /src/LSP/MessageHandler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module LSP.MessageHandler 4 | ( handler 5 | ) where 6 | 7 | import qualified Analyze.Diagnostics as Diagnostics 8 | import qualified AST.Canonical as Can 9 | import Control.Monad.Trans (liftIO) 10 | import qualified Elm.Compiler.Module as Module 11 | import Elm.Project.Json (Project) 12 | import qualified Elm.Project.Json as Project 13 | import qualified Elm.Project.Summary as Summary 14 | import qualified LSP.Data.Error as Error 15 | import qualified Data.List as List 16 | import Data.Text (Text) 17 | import qualified Data.Text as Text 18 | import qualified LSP.Data.FileEvent as FileEvent 19 | import qualified LSP.Data.FileChangeType as FileChangeType 20 | import LSP.Data.Message (Message) 21 | import qualified LSP.Data.Message as Message 22 | import LSP.Data.NotificationMethod ( TextDocumentDidOpenParams 23 | , TextDocumentDidChangeParams 24 | , TextDocumentDidSaveParams 25 | , DidChangeWatchedFilesParams 26 | ) 27 | import qualified LSP.Data.NotificationMethod as NotificationMethod 28 | import qualified LSP.Data.Position as Position 29 | import LSP.Data.RequestMethod (InitializeParams) 30 | import qualified LSP.Data.RequestMethod as RequestMethod 31 | import qualified LSP.Data.URI as URI 32 | import LSP.Data.Diagnostic (Diagnostic) 33 | import qualified LSP.Log as Log 34 | import qualified LSP.Misc 35 | import LSP.Model (Model) 36 | import qualified LSP.Model as M 37 | import LSP.Update (Msg) 38 | import qualified LSP.Update as U 39 | import Misc ((<|), (|>), andThen) 40 | import qualified Misc 41 | import qualified System.Directory as Dir 42 | import System.FilePath (()) 43 | import qualified System.FilePath as FilePath 44 | import qualified Stuff.Verify as Verify 45 | import Task (Task, SimpleTask) 46 | import qualified Task 47 | 48 | 49 | handler :: Model -> Message result -> SimpleTask Msg 50 | handler model incomingMessage = 51 | case (M._initialized model, incomingMessage) of 52 | (False, Message.RequestMessage id (RequestMethod.Initialize params)) -> 53 | requestInitializeTask id params 54 | |> Task.mapError (\errorMessage -> U.SendRequestError id Error.InternalError errorMessage) 55 | 56 | (False, _) -> 57 | U.SendNotifError Error.ServerNotInitialized "Server Not Initialized" 58 | |> return 59 | 60 | (True, Message.NotificationMessage NotificationMethod.Initialized) -> 61 | U.NoOp 62 | |> return 63 | 64 | (True, Message.NotificationMessage (NotificationMethod.TextDocumentDidOpen params)) -> 65 | textDocumentDidOpenTask model params 66 | |> Task.mapError (\errorMessage -> U.SendNotifError Error.InternalError errorMessage) 67 | 68 | (True, Message.NotificationMessage (NotificationMethod.TextDocumentDidChange params)) -> 69 | textDocumentDidChangeTask model params 70 | |> Task.mapError (\errorMessage -> U.SendNotifError Error.InvalidParams errorMessage) 71 | 72 | (True, Message.NotificationMessage (NotificationMethod.TextDocumentDidSave params)) -> 73 | textDocumentDidSaveTask model params 74 | |> Task.mapError (\errorMessage -> U.SendNotifError Error.InternalError errorMessage) 75 | 76 | (True, Message.NotificationMessage (NotificationMethod.DidChangeWatchedFiles params)) -> 77 | didChangeWatchedFilesTask model params 78 | |> Task.mapError (\errorMessage -> U.SendNotifError Error.InternalError errorMessage) 79 | 80 | (True, Message.RequestMessage _id (RequestMethod.TextDocumentHover _params)) -> 81 | U.RequestShutDown 82 | |> return 83 | 84 | (True, Message.RequestMessage _ RequestMethod.Shutdown) -> 85 | U.RequestShutDown 86 | |> return 87 | 88 | (True, Message.NotificationMessage NotificationMethod.Exit) -> 89 | U.Exit 90 | |> return 91 | 92 | (True, _) -> 93 | U.SendNotifError Error.MethodNotFound "Method not implemented" 94 | |> return 95 | 96 | 97 | requestInitializeTask:: Text -> InitializeParams -> Task Msg 98 | requestInitializeTask id (RequestMethod.InitializeParams uri) = 99 | do 100 | let (URI.URI projectRoot) = uri 101 | let clonedProjectRoot = M.cloneProject projectRoot 102 | elmExectuable <- LSP.Misc.findElmExectuable projectRoot 103 | LSP.Misc.verifyElmVersion elmExectuable 104 | elmProject <- readAndCloneElmProject projectRoot clonedProjectRoot 105 | elmSummary <- Task.fromElmTask <| Verify.verify (Text.unpack projectRoot) elmProject 106 | cloneElmSrc elmProject clonedProjectRoot 107 | let foreignInterfaces = Summary._ifaces elmSummary 108 | let foreignImportDict = LSP.Misc.getForeignImportDict foreignInterfaces 109 | localInterfaces <- LSP.Misc.readInterfaces elmProject projectRoot 110 | return 111 | (U.Initialize id 112 | projectRoot 113 | clonedProjectRoot 114 | elmExectuable 115 | elmProject 116 | elmSummary 117 | foreignInterfaces 118 | foreignImportDict 119 | localInterfaces 120 | ) 121 | 122 | 123 | textDocumentDidOpenTask:: Model -> TextDocumentDidOpenParams -> Task Msg 124 | textDocumentDidOpenTask model (NotificationMethod.TextDocumentDidOpenParams (uri, _version, source)) = 125 | do 126 | let (URI.URI filePath) = uri 127 | createFilePath <- createOrGetFileClone model filePath 128 | diagnostics <- getDiagnostics model createFilePath 129 | eitherCanonicalAndInterface <- getCanonicalAndInterface model source 130 | case eitherCanonicalAndInterface of 131 | Right (canonical, interface) -> 132 | return 133 | (U.UpdateModuleAndSendDiagnostics 134 | uri 135 | canonical 136 | (Can._name canonical) 137 | interface 138 | diagnostics 139 | ) 140 | 141 | Left _ -> 142 | return (U.SendDiagnostics uri diagnostics) 143 | 144 | 145 | textDocumentDidChangeTask:: Model -> TextDocumentDidChangeParams -> Task Msg 146 | textDocumentDidChangeTask model (NotificationMethod.TextDocumentDidChangeParams (uri, _version, contentChanges)) = 147 | do 148 | let (URI.URI filePath) = uri 149 | let lastContentChange = 150 | contentChanges 151 | |> List.reverse 152 | |> Misc.headSafe 153 | case lastContentChange of 154 | Nothing -> 155 | Task.throw "No document changes received" 156 | 157 | Just (NotificationMethod.ContentChange source) -> 158 | do 159 | clonedFilePath <- createOrGetFileClone model filePath 160 | updateFileContents clonedFilePath source 161 | diagnostics <- getDiagnostics model clonedFilePath 162 | eitherCanonicalAndInterface <- getCanonicalAndInterface model source 163 | case eitherCanonicalAndInterface of 164 | Right (canonical, interface) -> 165 | return 166 | (U.UpdateModuleAndSendDiagnostics 167 | uri 168 | canonical 169 | (Can._name canonical) 170 | interface 171 | diagnostics 172 | ) 173 | 174 | Left _ -> 175 | return (U.SendDiagnostics uri diagnostics) 176 | 177 | 178 | textDocumentDidSaveTask :: Model -> TextDocumentDidSaveParams -> Task Msg 179 | textDocumentDidSaveTask model (NotificationMethod.TextDocumentDidSaveParams uri) = 180 | do 181 | let (URI.URI filePath) = uri 182 | diagnostics <- getDiagnostics model filePath 183 | return (U.SendDiagnostics uri diagnostics) 184 | 185 | 186 | didChangeWatchedFilesTask :: Model -> DidChangeWatchedFilesParams -> Task Msg 187 | didChangeWatchedFilesTask model (NotificationMethod.DidChangeWatchedFilesParams params) = 188 | do 189 | let relevantChange = 190 | List.foldl 191 | (\acc cur@(FileEvent.FileEvent uri changeType) -> 192 | let 193 | (URI.URI filePath) = 194 | uri 195 | in 196 | if Text.isSuffixOf "elm.json" filePath then 197 | case changeType of 198 | FileChangeType.Changed -> 199 | Just cur 200 | 201 | _ -> 202 | acc 203 | else 204 | acc 205 | ) 206 | Nothing 207 | params 208 | case (M._package model, relevantChange) of 209 | (Just package, Just _) -> 210 | do 211 | let projectRoot = package |> M._projectRoot 212 | elmProject <- readAndCloneElmProject projectRoot (M._clonedProjectRoot package) 213 | elmSummary <- Task.fromElmTask <| Verify.verify (projectRoot |> Text.unpack) elmProject 214 | return (U.UpdateElmProjectAndSummary elmProject elmSummary) 215 | 216 | (_, Nothing) -> 217 | Task.throw "No relevant changes" 218 | 219 | (Nothing, _) -> 220 | Task.throw "No existing elm data" 221 | 222 | 223 | hover :: Text -> Model -> RequestMethod.TextDocumentHoverParams -> Msg 224 | hover id model (RequestMethod.TextDocumentHoverParams (uri, position)) = 225 | let 226 | (URI.URI filePath) = 227 | uri 228 | 229 | maybeClonedFilePath = 230 | M.switchProjectRootWithClonedProjectRoot 231 | model 232 | filePath 233 | 234 | (Position.Position (line, character)) = 235 | position 236 | in 237 | case maybeClonedFilePath of 238 | Nothing -> 239 | U.SendRequestError id Error.InternalError "Package not initialized" 240 | 241 | Just clonedFilePath -> 242 | -- todo: Search for reference with Oracle.hs 243 | U.SendRequestError id Error.InternalError "Package not initialized" 244 | 245 | 246 | 247 | -- TASKS 248 | 249 | 250 | -- This task clones the elm source to a cloned directory. 251 | -- We do this so we can save chages to the clone and provide 252 | -- as-you-type diagnostics to the user 253 | cloneElmSrc :: Project -> Text -> Task () 254 | cloneElmSrc project clonedProjectRoot = 255 | let 256 | sourceDirectories = 257 | case project of 258 | Project.App (Project.AppInfo {Project._app_source_dirs = dirs}) -> 259 | dirs 260 | 261 | Project.Pkg (Project.PkgInfo {}) -> 262 | ["."] 263 | 264 | clonedProjectRootString = 265 | Text.unpack clonedProjectRoot 266 | in 267 | sourceDirectories 268 | |> List.map 269 | (\path -> 270 | do 271 | baseTargetPath <- liftIO <| Dir.makeAbsolute (clonedProjectRootString path) 272 | baseSourcePath <- liftIO <| Dir.makeAbsolute path 273 | LSP.Misc.copyElmFileTree baseTargetPath baseSourcePath 274 | ) 275 | |> sequence_ 276 | 277 | 278 | -- This task runs the elm compiler with the flag `--report=json` on 279 | -- the given file and parses the results 280 | getDiagnostics :: Model -> Text -> Task [Diagnostic] 281 | getDiagnostics model filePath = 282 | case M._package model of 283 | Nothing -> 284 | Task.throw "Elm exectuable was not found" 285 | 286 | Just package -> 287 | Diagnostics.run (M._exectuable package) filePath 288 | 289 | 290 | -- This task writes the given changes (it expects the whole file) to the 291 | -- give path 292 | updateFileContents :: Text -> Text -> Task () 293 | updateFileContents filePath nextContent = 294 | writeFile (Text.unpack filePath) (Text.unpack nextContent) 295 | |> Task.lift 296 | 297 | 298 | -- This task takes the filePath given, and clones it (and it's parent directories) 299 | -- to the source clone 300 | createOrGetFileClone :: Model -> Text -> Task Text 301 | createOrGetFileClone model fullFilePath = 302 | do 303 | let maybeClonedFilePath = M.switchProjectRootWithClonedProjectRoot model fullFilePath 304 | case maybeClonedFilePath of 305 | Nothing -> 306 | Task.throw "Issue getting cloned file path" 307 | 308 | Just clonedFilePath -> 309 | do 310 | let fullFilePathString = Text.unpack fullFilePath 311 | let clonedFilePathString = Text.unpack clonedFilePath 312 | let parentDir = FilePath.takeDirectory clonedFilePathString 313 | doesExist <- Task.lift <| Dir.doesFileExist clonedFilePathString 314 | if doesExist then 315 | return clonedFilePath 316 | 317 | else 318 | do 319 | liftIO <| Dir.createDirectoryIfMissing True parentDir 320 | liftIO <| Dir.copyFile fullFilePathString clonedFilePathString 321 | return clonedFilePath 322 | 323 | 324 | -- Parse elm.json and clone it to our source clone 325 | readAndCloneElmProject :: Text -> Text -> Task Project 326 | readAndCloneElmProject projectRoot clonedRoot = 327 | do let projectPath = M.elmProjectPath projectRoot 328 | let projectPathString = Text.unpack projectPath 329 | let clonedRootString = Text.unpack clonedRoot 330 | let clonedProjectPathString = Text.unpack (M.elmProjectPath clonedRoot) 331 | project <- Task.fromElmTask (Project.read projectPathString) 332 | liftIO <| Dir.createDirectoryIfMissing True clonedRootString 333 | liftIO <| Dir.copyFile projectPathString clonedProjectPathString 334 | return project 335 | 336 | 337 | 338 | -- This is werid, but make a task always succeds 339 | -- with it's success value an Either. We do this 340 | -- because we don't want the failure to decode or 341 | -- to getting an interface to fail this entire 342 | -- message handler 343 | getCanonicalAndInterface :: Model -> Text -> Task (Either Text (Can.Module, Module.Interface)) 344 | getCanonicalAndInterface model source = 345 | decodeModule model source 346 | |> andThen 347 | (\canonical -> 348 | LSP.Misc.getInterface canonical 349 | |> fmap (\interface -> (canonical, interface)) 350 | ) 351 | |> Task.try 352 | |> liftIO 353 | 354 | 355 | -- Decode a module 356 | decodeModule :: Model -> Text -> Task Can.Module 357 | decodeModule model source = 358 | let 359 | maybePackage = 360 | model |> M._package 361 | in 362 | case maybePackage of 363 | Nothing -> 364 | Task.throw "No project" 365 | 366 | Just package -> 367 | let 368 | pkgName = 369 | package 370 | |> M._elmProject 371 | |> Project.getName 372 | in 373 | LSP.Misc.parseProgram pkgName source 374 | |> andThen 375 | (\valid -> 376 | LSP.Misc.canonicalize 377 | pkgName 378 | valid 379 | (M._foreignImportDict package) 380 | (M._localInterfaces package) 381 | (M._foreignInterfaces package) 382 | ) 383 | -------------------------------------------------------------------------------- /src/LSP/Misc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module LSP.Misc 6 | ( ioToEither 7 | , findElmExectuable 8 | , copyElmFileTree 9 | , verifyElmVersion 10 | , readInterfaces 11 | , parseProgram 12 | , getForeignImportDict 13 | , getLocalImportDict 14 | , canonicalize 15 | , getInterface 16 | , getAnnotations 17 | ) where 18 | 19 | import qualified AST.Canonical as Can 20 | import qualified AST.Source as Src 21 | import qualified AST.Valid as AST 22 | import qualified Canonicalize.Module as Canonicalize 23 | import Control.Exception (SomeException, tryJust) 24 | import Control.Monad.Trans (liftIO) 25 | import qualified Elm.Compiler.Module as Module 26 | import qualified Elm.Interface as I 27 | import qualified Elm.Name as N 28 | import Elm.Project.Json (Project) 29 | import qualified Elm.Project.Json as Project 30 | import Elm.Package as Package 31 | import qualified Data.Binary as Binary 32 | import qualified Data.List as List 33 | import qualified Data.Maybe as Maybe 34 | import qualified Data.HashMap.Strict as HM 35 | import qualified Data.Map as Map 36 | import Data.Semigroup ((<>)) 37 | import Data.Text (Text) 38 | import qualified Data.Text as Text 39 | import qualified Data.Text.Encoding as TextEncode 40 | import qualified LSP.Log as Log 41 | import qualified LSP.Model as M 42 | import Misc ((<|), (|>), andThen) 43 | import qualified Parse.Parse as Parse 44 | import qualified Reporting.Annotation as A 45 | import qualified Reporting.Result as ElmResult 46 | import qualified System.Directory as Dir 47 | import qualified System.FilePath as FilePath 48 | import System.FilePath (()) 49 | import qualified System.FilePath.Glob as Glob 50 | import Task (Task) 51 | import qualified Task 52 | import qualified Type.Constrain.Module as Type 53 | import qualified Type.Solve as Type 54 | import System.Exit as SysE 55 | import System.Process as SysP 56 | 57 | 58 | ioToEither :: IO value -> IO (Either Text value) 59 | ioToEither io = 60 | tryJust exceptionToText io 61 | 62 | 63 | exceptionToText :: SomeException -> Maybe Text 64 | exceptionToText ex = Just (Text.pack (show ex)) 65 | 66 | 67 | -- ELM EXECTUABLE SEARCH -- 68 | findElmExectuable :: Text -> Task Text 69 | findElmExectuable projectRoot = 70 | do 71 | let localPath = Text.unpack projectRoot ++ "/node_modules/.bin/elm" 72 | doesExist <- liftIO <| Dir.doesFileExist localPath 73 | if doesExist then 74 | localPath 75 | |> Text.pack 76 | |> return 77 | else 78 | do 79 | maybeExectuable <- liftIO <| Dir.findExecutable "elm" 80 | case maybeExectuable of 81 | Nothing -> 82 | Task.throw 83 | ("I couldn't find an elm executable! I didn't see" 84 | <> " it in \"node_modules/.bin/\" or your $PATH." 85 | ) 86 | 87 | Just executable -> 88 | return (Text.pack executable) 89 | 90 | 91 | -- VERIFY ELM VERSION 92 | verifyElmVersion :: Text -> Task () 93 | verifyElmVersion elmExectuablePath = 94 | do 95 | (exitCode, stdOutString, _stdErrString) <- 96 | liftIO <| 97 | SysP.readProcessWithExitCode 98 | (Text.unpack elmExectuablePath) 99 | ["--version"] 100 | "" 101 | case exitCode of 102 | SysE.ExitFailure _ -> 103 | Task.throw "Failed to read elm version" 104 | 105 | SysE.ExitSuccess -> 106 | case stdOutString of 107 | "0.19.0\n" -> 108 | return () 109 | 110 | _ -> 111 | Task.throw "Invalid elm version" 112 | 113 | 114 | -- COPY ELM FILE TREE 115 | extractDirectories :: [FilePath] -> [(FilePath, Bool)] 116 | extractDirectories paths = 117 | paths 118 | |> List.foldl 119 | (\acc curPath -> 120 | let 121 | parentDir = 122 | FilePath.takeDirectory curPath 123 | in 124 | acc 125 | |> HM.insert parentDir True 126 | |> HM.insert curPath False 127 | ) 128 | HM.empty 129 | |> HM.toList 130 | 131 | 132 | getSubElmProjects :: FilePath -> IO [FilePath] 133 | getSubElmProjects source = 134 | do 135 | filePaths <- Glob.globDir1 (Glob.compile ("**/" ++ M.elmProject)) source 136 | filePaths 137 | |> List.map 138 | (\path -> 139 | -- We subtract the extra 1 to remove the trailing "/" 140 | List.take 141 | (List.length path - List.length M.elmProject - 1) 142 | path 143 | ) 144 | |> List.filter 145 | (\path -> 146 | path /= source && not (M.elmStuff `List.isInfixOf` path) 147 | ) 148 | |> return 149 | 150 | 151 | isPrefixOfAny :: [FilePath] -> FilePath -> Bool 152 | isPrefixOfAny listOfDirs filePath = 153 | List.foldr 154 | (\dir hasAlreadyFoundMatch -> 155 | if hasAlreadyFoundMatch then 156 | True 157 | 158 | else 159 | List.isPrefixOf dir filePath 160 | ) 161 | False 162 | listOfDirs 163 | 164 | 165 | getElmFiles :: FilePath -> IO [(FilePath, Bool)] 166 | getElmFiles !source = 167 | do 168 | filePaths <- Glob.globDir1 (Glob.compile "**/*.elm") source 169 | subElmProjectPaths <- getSubElmProjects source 170 | filePaths 171 | |> List.filter 172 | (\item -> 173 | not (List.isInfixOf M.elmStuff item) 174 | && not (item |> isPrefixOfAny subElmProjectPaths) 175 | ) 176 | |> List.map 177 | (\path -> 178 | path 179 | |> List.stripPrefix source 180 | |> fmap (List.drop 1) 181 | |> Maybe.fromMaybe path 182 | ) 183 | |> extractDirectories 184 | |> return 185 | 186 | 187 | copyItem :: FilePath -> FilePath -> (FilePath, Bool) -> IO () 188 | copyItem !baseSourcePath !baseTargetPath (relativePath, isDir) = 189 | let 190 | sourcePath = 191 | baseSourcePath relativePath 192 | 193 | targetPath = 194 | baseTargetPath relativePath 195 | in 196 | if isDir then 197 | Dir.createDirectoryIfMissing True targetPath 198 | 199 | else 200 | Dir.copyFile sourcePath targetPath 201 | 202 | 203 | copyElmFileTreeHelper :: FilePath -> FilePath -> IO () 204 | copyElmFileTreeHelper !destination !source = 205 | Dir.createDirectoryIfMissing True destination >> 206 | getElmFiles source >>= \subItems -> 207 | subItems 208 | |> List.foldl 209 | (\(dirs, paths) cur@(_path, isDir) -> 210 | if isDir then 211 | (cur : dirs, paths) 212 | 213 | else 214 | (dirs, cur : paths) 215 | ) 216 | ([], []) 217 | |> (\(dirs, paths) -> dirs ++ paths) 218 | |> mapM_ (copyItem source destination) 219 | 220 | 221 | copyElmFileTree :: FilePath -> FilePath -> Task () 222 | copyElmFileTree destination source = 223 | Task.lift 224 | (copyElmFileTreeHelper 225 | (FilePath.normalise destination) 226 | (FilePath.normalise source) 227 | ) 228 | 229 | 230 | -- Read in *.elmi files as interfaces 231 | readInterfaces :: Project -> Text -> Task Module.Interfaces 232 | readInterfaces project projectRoot = 233 | let 234 | projectName = 235 | project 236 | |> Project.getName 237 | 238 | interfacesPath = 239 | projectRoot 240 | |> M.elmInterfacesPath 241 | |> Text.unpack 242 | in 243 | do 244 | filePaths <- liftIO <| Glob.globDir1 (Glob.compile "**/*.elmi") interfacesPath 245 | tuples <- mapM (readInterface projectName) filePaths 246 | tuples 247 | |> Map.fromList 248 | |> return 249 | 250 | 251 | readInterface :: Package.Name -> FilePath -> Task (Module.Canonical, Module.Interface) 252 | readInterface pkgName filePath = 253 | let 254 | maybeRawModuleName = 255 | filePath 256 | |> FilePath.takeBaseName 257 | |> Text.pack 258 | |> Module.fromHyphenPath 259 | in 260 | do 261 | doesExist <-liftIO (Dir.doesFileExist filePath) 262 | case (doesExist, maybeRawModuleName) of 263 | (True, Just rawModuleName) -> 264 | do 265 | decoded <- liftIO (Binary.decodeFile filePath) 266 | return (Module.Canonical pkgName rawModuleName, decoded) 267 | 268 | (False, _)-> 269 | Task.throw ("File \"" <> Text.pack filePath <> "\" was not found") 270 | 271 | (_, Nothing)-> 272 | Task.throw ("File \"" <> Text.pack filePath <> "\" didn't have a valid name") 273 | 274 | 275 | -- Parse into AST 276 | parseProgram :: Package.Name -> Text -> Task AST.Module 277 | parseProgram pkgName source = 278 | source 279 | |> TextEncode.encodeUtf8 280 | |> Parse.program pkgName 281 | |> andThen ElmResult.ok 282 | |> Task.fromElmResult (\_ -> "Failed to validate AST") 283 | 284 | 285 | -- Get imports for a module 286 | getForeignImportDict :: Module.Interfaces -> M.ImportDict 287 | getForeignImportDict foreignInterfaces = 288 | foreignInterfaces 289 | |> Map.toList 290 | |> List.map (\(canonical@(Module.Canonical _ name), _) -> (name, canonical)) 291 | |> Map.fromList 292 | 293 | 294 | getLocalImportDict :: Package.Name -> AST.Module -> M.ImportDict 295 | getLocalImportDict pkgName localModule = 296 | localModule 297 | |> AST._imports 298 | |> List.map 299 | (\(Src.Import (A.At _ importName) _ _) -> 300 | (importName, Module.Canonical pkgName importName) 301 | ) 302 | |> Map.fromList 303 | 304 | 305 | -- Get canonicalized version of AST 306 | canonicalize :: Package.Name -> AST.Module -> M.ImportDict -> Module.Interfaces -> Module.Interfaces -> Task Can.Module 307 | canonicalize pkgName localModule foreignImportDict localInterfaces foreignInterfaces = 308 | let 309 | -- Map.union is left-biased, so foreigns override locals 310 | importDict = 311 | Map.union foreignImportDict (getLocalImportDict pkgName localModule) 312 | 313 | -- Map.union is left-biased, so foreigns override locals 314 | interfaces = 315 | Map.union foreignInterfaces localInterfaces 316 | 317 | in 318 | do 319 | Canonicalize.canonicalize pkgName importDict interfaces localModule 320 | |> Task.fromElmResult (\_ -> "Failed to canonicalized") 321 | 322 | 323 | 324 | -- Get canonicalized version of AST 325 | getInterface :: Can.Module -> Task Module.Interface 326 | getInterface canonical = 327 | fmap (\annotations -> I.fromModule annotations canonical) 328 | (getAnnotations canonical) 329 | 330 | 331 | -- Get type annotations from canonical AST 332 | getAnnotations :: Can.Module -> Task (Map.Map N.Name Can.Annotation) 333 | getAnnotations canonical = 334 | do 335 | constraint <- liftIO <| Type.constrain canonical 336 | either <- liftIO <| Type.run constraint 337 | case either of 338 | Left _ -> 339 | Task.throw "Failed to get annotations" 340 | 341 | Right annotations -> 342 | return annotations 343 | -------------------------------------------------------------------------------- /src/LSP/Model.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | 4 | module LSP.Model 5 | ( Model(..) 6 | , Package(..) 7 | , ImportDict 8 | , ASTs 9 | , elmProject 10 | , elmProjectPath 11 | , elmStuff 12 | , elmStuffPath 13 | , elmInterfacesPath 14 | , cloneProject 15 | , switchProjectRootWithClonedProjectRoot 16 | ) where 17 | 18 | import qualified AST.Canonical as Can 19 | import Data.Map (Map) 20 | import Data.Text (Text) 21 | import qualified Data.Text as Text 22 | import Data.Semigroup ((<>)) 23 | import qualified Elm.Compiler.Module as Module 24 | import qualified Elm.Name as N 25 | import qualified Elm.Package as P 26 | import Elm.Project.Json (Project) 27 | import Elm.Project.Summary (Summary) 28 | import LSP.Data.URI (URI) 29 | import Misc ((|>)) 30 | import System.FilePath (()) 31 | import Prelude hiding (init) 32 | 33 | 34 | data Model = Model 35 | { _shouldTerminate :: Bool 36 | , _initialized :: Bool 37 | , _package :: Maybe Package 38 | } deriving (Show) 39 | 40 | 41 | data Package = Package 42 | { _projectRoot :: Text 43 | , _clonedProjectRoot :: Text 44 | , _exectuable :: Text 45 | , _elmProject :: Project 46 | , _elmSummary :: Summary 47 | , _foreignInterfaces :: Module.Interfaces 48 | , _foreignImportDict :: ImportDict 49 | , _localInterfaces :: Module.Interfaces 50 | , _asts :: ASTs 51 | -- TODO: Add elm-format path? 52 | } 53 | 54 | 55 | type ImportDict = 56 | Map Module.Raw Module.Canonical 57 | 58 | 59 | type ASTs = 60 | Map URI Can.Module 61 | 62 | 63 | elmProject :: String 64 | elmProject = "elm.json" 65 | 66 | 67 | elmProjectPath :: Text -> Text 68 | elmProjectPath root = 69 | Text.pack (Text.unpack root elmProject) 70 | 71 | 72 | elmStuff :: String 73 | elmStuff = "elm-stuff" 74 | 75 | 76 | elmStuffPath :: Text -> Text 77 | elmStuffPath root = 78 | Text.pack (Text.unpack root elmStuff) 79 | 80 | 81 | elmInterfacesPath :: Text -> Text 82 | elmInterfacesPath root = 83 | Text.pack (Text.unpack root elmStuff "0.19.0") 84 | 85 | 86 | cloneProject :: Text -> Text 87 | cloneProject root = 88 | Text.pack (Text.unpack root elmStuff ".lsp/clone") 89 | 90 | 91 | switchProjectRootWithClonedProjectRoot :: Model -> Text -> Maybe Text 92 | switchProjectRootWithClonedProjectRoot model filePath = 93 | _package model >>= 94 | \package -> 95 | let 96 | projectRoot = 97 | _projectRoot package 98 | 99 | clonedProjectroot = 100 | _clonedProjectRoot package 101 | in 102 | filePath 103 | |> Text.stripPrefix projectRoot 104 | |> fmap (\suffix -> clonedProjectroot <> suffix) 105 | 106 | 107 | -- INSTANCES 108 | 109 | 110 | instance Show Package where 111 | show (Package root cloneRoot exectuable _project _summary _fi _fid _li _asts) = 112 | "Package: {" 113 | ++ "_projectRoot = " 114 | ++ show root 115 | ++ " _clonedProjectRoot = " 116 | ++ show cloneRoot 117 | ++ " _exectuable = " 118 | ++ show exectuable 119 | ++ "}" 120 | 121 | 122 | instance Show N.Name where 123 | show name = 124 | "Name: " ++ N.toString name 125 | 126 | 127 | instance Show P.Name where 128 | show name = 129 | "Name: " ++ P.toString name 130 | 131 | 132 | instance Show Module.Canonical where 133 | show (Module.Canonical pkgName name) = 134 | "Name: {_package = " ++ show pkgName ++ ", _module = " ++ show name ++ "}" 135 | -------------------------------------------------------------------------------- /src/LSP/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module LSP.Server 4 | ( run 5 | ) where 6 | 7 | import Control.Exception (SomeException, catch) 8 | import qualified Data.ByteString.Lazy as BS 9 | import qualified Data.List as List 10 | import qualified LSP.Data.Message as Message 11 | import qualified LSP.Log as Log 12 | import LSP.Model (Model) 13 | import qualified LSP.Update as U 14 | import qualified LSP.MessageHandler as MessageHandler 15 | import qualified System.IO as IO 16 | import qualified Task 17 | 18 | run :: IO Int 19 | run = 20 | do 21 | IO.hSetBuffering IO.stdin IO.NoBuffering 22 | IO.hSetEncoding IO.stdin IO.utf8 23 | IO.hSetBuffering IO.stdout IO.NoBuffering 24 | IO.hSetEncoding IO.stdout IO.utf8 25 | catch (loop U.init) handleException 26 | 27 | loop :: Model -> IO Int 28 | loop model = 29 | do 30 | decoded <- Message.decode IO.stdin 31 | case decoded of 32 | Left _ -> 33 | loop model 34 | 35 | Right message -> 36 | do 37 | -- Log.logger ("Message: " ++ show message) 38 | let task = MessageHandler.handler model message 39 | msg <- Task.run task 40 | let (nextModel, response, termination) = U.update msg model 41 | let responseIO = 42 | case response of 43 | U.None -> 44 | return () 45 | 46 | U.Send byteString -> 47 | BS.putStr byteString 48 | 49 | U.SendMany byteStrings -> 50 | sequence_ (List.map BS.putStr byteStrings) 51 | Log.logger ("Msg: " ++ show msg) 52 | Log.logger ("Response: " ++ show response) 53 | Log.logger ("Model: " ++ show model ++ "\n") 54 | case termination of 55 | U.ShouldTerminate -> 56 | return 1 57 | 58 | U.ShouldNotTerminate -> 59 | responseIO >> loop nextModel 60 | 61 | handleException :: SomeException -> IO Int 62 | handleException ex = 63 | print ex >> Log.logger ex >> return 1 64 | -------------------------------------------------------------------------------- /src/LSP/Update.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module LSP.Update 4 | ( init 5 | , Msg(..) 6 | , update 7 | , Response(..) 8 | , ShouldTermiate(..) 9 | ) where 10 | 11 | import qualified Data.ByteString.Lazy as BS 12 | import Data.Semigroup ((<>)) 13 | import Data.Map (Map) 14 | import qualified Data.Map as Map 15 | import Data.Text (Text) 16 | import qualified AST.Canonical as Can 17 | import qualified Elm.Compiler.Module as Module 18 | import Elm.Project.Json (Project) 19 | import Elm.Project.Summary (Summary) 20 | import qualified LSP.Data.Capabilities as Capabilities 21 | import LSP.Data.Error (Error) 22 | import qualified LSP.Data.Error as Error 23 | import qualified LSP.Data.FileSystemWatcher as FileSystemWatcher 24 | import LSP.Data.Message (Message) 25 | import qualified LSP.Data.Message as Message 26 | import qualified LSP.Data.Registration as Registration 27 | import LSP.Data.Diagnostic (Diagnostic) 28 | import qualified LSP.Data.MessageError as MessageError 29 | import qualified LSP.Data.NotificationMethod as NotifMethod 30 | import qualified LSP.Data.FileChangeType as FileChangeType 31 | import LSP.Data.URI (URI) 32 | import LSP.Model (Model) 33 | import qualified LSP.Model as M 34 | import Misc ((<|), (|>)) 35 | import Prelude hiding (init) 36 | 37 | init :: Model 38 | init = M.Model False False Nothing 39 | 40 | data Response 41 | = Send BS.ByteString 42 | | SendMany [BS.ByteString] 43 | | None 44 | deriving (Show) 45 | 46 | data ShouldTermiate 47 | = ShouldTerminate 48 | | ShouldNotTerminate 49 | deriving (Show) 50 | 51 | data Msg 52 | = Initialize 53 | Text 54 | Text 55 | Text 56 | Text 57 | Project 58 | Summary 59 | Module.Interfaces 60 | M.ImportDict 61 | Module.Interfaces 62 | | SendDiagnostics URI [Diagnostic] 63 | | UpdateModuleAndSendDiagnostics 64 | URI 65 | Can.Module 66 | Module.Canonical 67 | Module.Interface 68 | [Diagnostic] 69 | | UpdateElmProjectAndSummary Project Summary 70 | | RequestShutDown 71 | | Exit 72 | | SendRequestError Text Error Text 73 | | SendNotifError Error Text 74 | | InvalidElmVersion Text 75 | | NoOp 76 | 77 | 78 | 79 | update :: Msg -> Model -> (Model, Response, ShouldTermiate) 80 | update msg model = 81 | case msg of 82 | Initialize id projectRoot clonedProjectRoot executable project summary foreignInterfaces foreignImportDict localInterfaces -> 83 | ( model 84 | { M._initialized = True 85 | , M._package = 86 | Just <| 87 | M.Package projectRoot 88 | clonedProjectRoot 89 | executable 90 | project 91 | summary 92 | foreignInterfaces 93 | foreignImportDict 94 | localInterfaces 95 | Map.empty -- Local ASTs, will be populated by on-change handlers 96 | } 97 | , SendMany 98 | [ Message.encode 99 | (Message.ResponseMessage 100 | (Just id) 101 | (Just Capabilities.capabilities) 102 | Nothing 103 | ) 104 | , [ Registration.DidChangeWatchedFiles 105 | "watching" 106 | [ FileSystemWatcher.FileSystemWatcher 107 | (M.elmProjectPath projectRoot) 108 | (Just FileChangeType.Changed) 109 | ] 110 | ] 111 | |> NotifMethod.RegisterCapabilityParams 112 | |> NotifMethod.RegisterCapability 113 | |> Message.NotificationMessage 114 | |> (Message.encode :: Message () -> BS.ByteString) 115 | ] 116 | , ShouldNotTerminate 117 | ) 118 | 119 | SendDiagnostics uri diagnostics -> 120 | ( model 121 | , (uri, diagnostics) 122 | |> encodeDiagnostics 123 | |> Send 124 | , ShouldNotTerminate 125 | ) 126 | 127 | UpdateModuleAndSendDiagnostics uri canonical moduleName interface diagnostics -> 128 | ( model 129 | { M._package = 130 | model 131 | |> M._package 132 | |> fmap 133 | (\package -> 134 | package 135 | { M._localInterfaces = 136 | Map.insert 137 | moduleName 138 | interface 139 | (M._localInterfaces package) 140 | , M._asts = 141 | Map.insert 142 | uri 143 | canonical 144 | (M._asts package) 145 | } 146 | ) 147 | } 148 | , (uri, diagnostics) 149 | |> encodeDiagnostics 150 | |> Send 151 | , ShouldNotTerminate 152 | ) 153 | 154 | UpdateElmProjectAndSummary elmProject elmSummary -> 155 | ( model 156 | { M._package = 157 | model 158 | |> M._package 159 | |> fmap 160 | (\package -> 161 | package 162 | { M._elmProject = elmProject 163 | , M._elmSummary = elmSummary 164 | } 165 | ) 166 | } 167 | , None 168 | , ShouldNotTerminate 169 | ) 170 | 171 | RequestShutDown -> 172 | ( model { M._shouldTerminate = True } 173 | , None 174 | , ShouldNotTerminate 175 | ) 176 | 177 | Exit -> 178 | (model, None, ShouldTerminate) 179 | 180 | SendRequestError id error errorMessage -> 181 | let messageError = MessageError.MessageError error errorMessage 182 | message :: Message () 183 | message = 184 | Message.ResponseMessage (Just id) Nothing (Just messageError) 185 | in 186 | ( model 187 | , Send (Message.encode message) 188 | , ShouldNotTerminate 189 | ) 190 | 191 | SendNotifError error errorMessage -> 192 | let messageError = MessageError.MessageError error errorMessage 193 | message :: Message () 194 | message = 195 | Message.ResponseMessage Nothing Nothing (Just messageError) 196 | in 197 | ( model 198 | , Send (Message.encode message) 199 | , ShouldNotTerminate 200 | ) 201 | 202 | InvalidElmVersion id -> 203 | ( model 204 | , SendMany 205 | [ NotifMethod.ShowMessageParams NotifMethod.Info 206 | "elm-language-server is only compatible with Elm v0.19.0 and greater" 207 | |> NotifMethod.ShowMessage 208 | |> Message.NotificationMessage 209 | |> (Message.encode :: Message () -> BS.ByteString) 210 | , let 211 | messageError = 212 | MessageError.MessageError 213 | Error.UnknownErrorCode 214 | "elm-language-server is only compatible with Elm v0.19.0 and greater" 215 | in 216 | Message.ResponseMessage (Just id) Nothing 217 | (Just messageError) 218 | |> (Message.encode :: Message () -> BS.ByteString) 219 | ] 220 | , ShouldTerminate 221 | ) 222 | 223 | NoOp -> 224 | ( model 225 | , None 226 | , ShouldNotTerminate 227 | ) 228 | 229 | encodeDiagnostics :: (URI, [Diagnostic]) -> BS.ByteString 230 | encodeDiagnostics tuple = 231 | let encode :: Message () -> BS.ByteString 232 | encode = Message.encode 233 | in 234 | tuple 235 | |> NotifMethod.PublishDiagnosticsParams 236 | |> NotifMethod.PublishDiagnostics 237 | |> Message.NotificationMessage 238 | |> encode 239 | 240 | 241 | -- INSTANCES 242 | 243 | 244 | instance Show Msg where 245 | show msg = 246 | case msg of 247 | Initialize {} -> 248 | "Initialize" 249 | 250 | UpdateModuleAndSendDiagnostics {} -> 251 | "UpdateModuleAndSendDiagnostics" 252 | 253 | SendDiagnostics {} -> 254 | "SendDiagnostics" 255 | 256 | UpdateElmProjectAndSummary {} -> 257 | "UpdateElmProjectAndSummary" 258 | 259 | RequestShutDown -> 260 | "RequestShutDown" 261 | 262 | Exit -> 263 | "Exit" 264 | 265 | SendRequestError _ _ _ -> 266 | "SendRequestError" 267 | 268 | SendNotifError _ _ -> 269 | "SendNotifError" 270 | 271 | InvalidElmVersion _ -> 272 | "InvalidElmVersion" 273 | 274 | NoOp -> 275 | "NoOp" 276 | -------------------------------------------------------------------------------- /src/Misc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Misc 4 | ( isWindows 5 | , (|>) 6 | , (<|) 7 | , headSafe 8 | , curryTriple 9 | , mapLeft 10 | , eitherToMaybe 11 | , maybeToEither 12 | , map2 13 | , andThen 14 | , toInt 15 | , byteStringToText 16 | , textToByteString 17 | ) where 18 | 19 | import qualified Data.ByteString.Lazy as BS 20 | import Data.Text (Text) 21 | import qualified Data.Char as Char 22 | import qualified Data.Text as Text 23 | import qualified Data.Text.Encoding as TextEncode 24 | import Data.Word (Word8) 25 | import System.Info as SysInfo 26 | 27 | 28 | (|>) :: a -> (a -> b) -> b 29 | (|>) = flip ($) 30 | 31 | 32 | (<|) :: (a -> b) -> a -> b 33 | (<|) = ($) 34 | 35 | 36 | isWindows :: Bool 37 | isWindows = 38 | SysInfo.os == "mingw32" 39 | 40 | 41 | headSafe :: [a] -> Maybe a 42 | headSafe list = 43 | case list of 44 | head : _ -> 45 | Just head 46 | 47 | _ -> 48 | Nothing 49 | 50 | 51 | curryTriple :: ((a, b, c) -> d) -> a -> b -> c -> d 52 | curryTriple f a b c = f (a, b, c) 53 | 54 | 55 | mapLeft :: (a -> b) -> Either a e -> Either b e 56 | mapLeft func either = 57 | case either of 58 | Left a -> Left (func a) 59 | Right e -> Right e 60 | 61 | 62 | eitherToMaybe :: Either error value -> Maybe value 63 | eitherToMaybe either = 64 | case either of 65 | Left _ -> 66 | Nothing 67 | 68 | Right value -> 69 | Just value 70 | 71 | 72 | maybeToEither :: error -> Maybe value -> Either error value 73 | maybeToEither error maybe = 74 | case maybe of 75 | Nothing -> Left error 76 | Just value -> Right value 77 | 78 | 79 | map2 :: Monad m => (a -> b -> result) -> m a -> m b -> m result 80 | map2 func a b = 81 | return func 82 | <*> a 83 | <*> b 84 | 85 | 86 | andThen :: Monad m => (a -> m b) -> m a -> m b 87 | andThen = (=<<) 88 | 89 | 90 | toInt :: (RealFloat r, Integral i) => Either r i -> Int 91 | toInt num = 92 | case num of 93 | Left float -> fromIntegral (round float) 94 | Right integral -> fromIntegral integral 95 | 96 | 97 | byteStringToText :: BS.ByteString -> Text 98 | byteStringToText byteString = 99 | case TextEncode.decodeUtf8' (BS.toStrict byteString) of 100 | Left _ -> "" 101 | Right value -> value 102 | 103 | 104 | toWord8 :: Text -> [Word8] 105 | toWord8 = Text.foldr (\c acc -> fromIntegral (Char.ord c) : acc) [] 106 | 107 | 108 | textToByteString :: Text -> BS.ByteString 109 | textToByteString text = 110 | text 111 | |> toWord8 112 | |> BS.pack 113 | -------------------------------------------------------------------------------- /src/Result.hs: -------------------------------------------------------------------------------- 1 | module Result 2 | ( fromElmResult 3 | ) where 4 | 5 | 6 | import qualified Reporting.Result as ElmResult 7 | 8 | 9 | fromElmResult :: ElmResult.Result () [w] error a -> Maybe a 10 | fromElmResult result = 11 | let 12 | (_warnings, either) = 13 | ElmResult.run result 14 | in 15 | case either of 16 | Left _errors -> 17 | Nothing 18 | 19 | Right value -> 20 | Just value 21 | -------------------------------------------------------------------------------- /src/Task.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Task 4 | ( Task 5 | , SimpleTask 6 | , try 7 | , run 8 | , throw 9 | , mapError 10 | , lift 11 | , liftEither 12 | , fromElmTask 13 | , fromElmResult 14 | ) where 15 | 16 | import qualified Control.Monad.Except as E 17 | import Control.Monad.Trans (liftIO) 18 | import Control.Exception (SomeException, tryJust) 19 | import qualified Data.List as List 20 | import Data.Semigroup ((<>)) 21 | import Data.Text (Text) 22 | import qualified Data.Text as Text 23 | import qualified Reporting.Task as ElmTask 24 | import qualified Reporting.Progress as ElmProgress 25 | import qualified Reporting.Result as ElmResult 26 | import qualified Reporting.Exit as ElmExit 27 | import Misc ((<|), (|>)) 28 | 29 | 30 | type Task value = 31 | Task_ Text value 32 | 33 | 34 | type SimpleTask value = 35 | Task_ value value 36 | 37 | 38 | type Task_ error value = 39 | E.ExceptT error IO value 40 | 41 | 42 | try :: Task value -> IO (Either Text value) 43 | try task = 44 | E.runExceptT task 45 | 46 | 47 | run :: SimpleTask msg -> IO msg 48 | run task = 49 | do 50 | either <- E.runExceptT task 51 | let result = 52 | case either of 53 | Left value -> 54 | value 55 | 56 | Right value -> 57 | value 58 | return result 59 | 60 | 61 | throw :: e -> Task_ e a 62 | throw error = 63 | E.throwError error 64 | 65 | 66 | mapError :: (x -> y) -> Task_ x a -> Task_ y a 67 | mapError = 68 | E.withExceptT 69 | 70 | 71 | liftEither :: Either error value -> Task_ error value 72 | liftEither e = 73 | either throw return e 74 | 75 | 76 | ioToEither :: IO value -> IO (Either Text value) 77 | ioToEither io = 78 | tryJust exceptionToText io 79 | 80 | 81 | exceptionToText :: SomeException -> Maybe Text 82 | exceptionToText ex = 83 | Just (Text.pack (show ex)) 84 | 85 | 86 | lift :: IO value -> Task value 87 | lift io = 88 | do 89 | either <- liftIO <| ioToEither io 90 | liftEither either 91 | 92 | 93 | fromElmTask :: ElmTask.Task value -> Task value 94 | fromElmTask elmTask = 95 | do 96 | result <- liftIO <| ElmTask.tryWithError ElmProgress.silentReporter elmTask 97 | case result of 98 | Left exit -> 99 | exit 100 | |> ElmExit.toString 101 | |> Text.pack 102 | |> throw 103 | 104 | Right value -> 105 | return value 106 | 107 | 108 | fromElmResult :: (err -> Text) -> ElmResult.Result () [w] err a -> Task a 109 | fromElmResult errorToText result = 110 | let 111 | (_warnings, either) = 112 | ElmResult.run result 113 | in 114 | case either of 115 | Left errors -> 116 | errors 117 | |> List.foldr 118 | (\curError acc -> 119 | acc <> "," <> errorToText curError 120 | ) 121 | "" 122 | |> Task.throw 123 | 124 | Right value -> 125 | return value 126 | -------------------------------------------------------------------------------- /src/Version.hs: -------------------------------------------------------------------------------- 1 | module Version 2 | ( asString 3 | ) where 4 | 5 | import qualified Paths_elm_language_server 6 | import qualified Data.Version 7 | 8 | 9 | asString :: String 10 | asString = 11 | Data.Version.showVersion Paths_elm_language_server.version 12 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-11.22 2 | 3 | packages: 4 | - . 5 | 6 | extra-deps: 7 | - github: elm-tooling/elm-compiler-library 8 | commit: 5354f1f4955131377b1626f8fe75ed823f5525ae 9 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import qualified Data.ByteString as BS 4 | import qualified Data.Char as Char 5 | import qualified Data.List as List 6 | import qualified Data.Map as Map 7 | import Data.Semigroup ((<>)) 8 | import Data.Text (Text) 9 | import qualified Data.Text as Text 10 | import qualified Data.Map as Map 11 | import Data.Word (Word8) 12 | import Test.Tasty 13 | import Test.Tasty.HUnit 14 | 15 | 16 | -- Elm 17 | import qualified AST.Valid as Valid 18 | import qualified AST.Canonical as Can 19 | import qualified Canonicalize.Module as Canonicalize 20 | import qualified Elm.Name as N 21 | import qualified Elm.Package as Pkg 22 | import qualified Elm.Project.Json as Project 23 | import qualified Elm.Project.Summary as Summary 24 | import qualified Parse.Parse as Parse 25 | import qualified Reporting.Render.Type.Localizer as L 26 | import qualified Reporting.Result as Result 27 | import qualified Stuff.Verify as Verify 28 | 29 | 30 | -- Internal Modules 31 | import qualified Analyze.Search as Search 32 | import qualified LSP.Misc as LSPMisc 33 | import Misc ((<|), (|>), andThen) 34 | import qualified Task as Task 35 | 36 | 37 | main :: IO () 38 | main = 39 | defaultMain 40 | (testGroup "Tests" 41 | [ parseTests 42 | , searchTests 43 | , hoverTests 44 | ] 45 | ) 46 | 47 | 48 | -- Test Helpers 49 | 50 | 51 | testPkgName :: Pkg.Name 52 | testPkgName = Pkg.Name "Jared Ramirez" "Test" 53 | 54 | 55 | parse :: Task.Task Valid.Module 56 | parse = 57 | do 58 | raw <- 59 | BS.readFile "./test/sample/src/Main.elm" 60 | |> Task.lift 61 | 62 | Parse.program testPkgName raw 63 | |> Task.fromElmResult (\_ -> "Failed to parse") 64 | 65 | 66 | parseAndCanonicalize :: Task.Task Can.Module 67 | parseAndCanonicalize = 68 | do 69 | parsed <- parse 70 | 71 | project <- 72 | Project.read "./test/sample/elm.json" 73 | |> Task.fromElmTask 74 | 75 | ifaces <- 76 | Verify.verify "./test/safe" project 77 | |> Task.fromElmTask 78 | |> fmap Summary._ifaces 79 | 80 | let importDict = 81 | LSPMisc.getForeignImportDict ifaces 82 | 83 | Canonicalize.canonicalize testPkgName importDict ifaces parsed 84 | |> Task.fromElmResult (\_ -> "Failed to canonicalize") 85 | 86 | 87 | searchModule :: Int -> Int -> Task.Task Search.Value 88 | searchModule line column = 89 | do 90 | canonical <- 91 | parseAndCanonicalize 92 | 93 | let maybeFound = 94 | Search.getInfo canonical (Search.Location line column) 95 | 96 | case maybeFound of 97 | Nothing -> 98 | Task.throw "Not found" 99 | 100 | Just found -> 101 | return found 102 | 103 | 104 | hover :: Int -> Int -> Task.Task Search.HoverResult 105 | hover line column = 106 | do 107 | parsed <- parse 108 | project <- 109 | Project.read "./test/sample/elm.json" 110 | |> Task.fromElmTask 111 | ifaces <- 112 | Verify.verify "./test/safe" project 113 | |> Task.fromElmTask 114 | |> fmap Summary._ifaces 115 | let importDict = LSPMisc.getForeignImportDict ifaces 116 | canonical <- 117 | Canonicalize.canonicalize testPkgName importDict ifaces parsed 118 | |> Task.fromElmResult (\_ -> "Failed to canonicalize") 119 | let localizer = L.fromModule parsed 120 | Search.hover canonical localizer line column 121 | 122 | -- Tests 123 | 124 | 125 | parseTests :: TestTree 126 | parseTests = 127 | testGroup 128 | "Parse and Canonicalize Tests" 129 | [ testCase 130 | "Parse Module" 131 | (Task.try parse >>= \result -> 132 | case result of 133 | Left message -> assertFailure (Text.unpack message) 134 | Right _ -> return () 135 | ) 136 | , testCase 137 | "Canoncailize Module" 138 | (Task.try parseAndCanonicalize >>= \result -> 139 | case result of 140 | Left message -> assertFailure (Text.unpack message) 141 | Right _ -> return () 142 | ) 143 | ] 144 | 145 | searchTests :: TestTree 146 | searchTests = 147 | testGroup 148 | "Search Tests" 149 | [ testCase 150 | "Top-level un-typed primitive value search" 151 | (Task.try (searchModule 5 11) >>= \result -> 152 | case result of 153 | Left message -> assertFailure (Text.unpack message) 154 | Right value -> 155 | case value of 156 | Search.Type _ canType -> 157 | case Search.canTypeToText canType of 158 | "String" -> 159 | return () 160 | 161 | invalid -> 162 | ("Got a reference but it was \"" <> invalid <> "\" instead of \"String\"") 163 | |> Text.unpack 164 | |> assertFailure 165 | 166 | Search.Debug message -> 167 | assertFailure ("DEBUG: " ++ message) 168 | 169 | _ -> 170 | assertFailure "Expected primitive type" 171 | ) 172 | , testCase 173 | "Top-level typed primitive value search" 174 | (Task.try (searchModule 10 5) >>= \result -> 175 | case result of 176 | Left message -> assertFailure (Text.unpack message) 177 | Right value -> 178 | case value of 179 | Search.Type _ canType -> 180 | case Search.canTypeToText canType of 181 | "()" -> 182 | return () 183 | 184 | invalid -> 185 | ("Got a type but it was \"" <> invalid <> "\" instead of \"String\"") 186 | |> Text.unpack 187 | |> assertFailure 188 | 189 | Search.Debug message -> 190 | assertFailure ("DEBUG: " ++ message) 191 | 192 | _ -> 193 | assertFailure "Expected primitive type" 194 | ) 195 | , testCase 196 | "Top-level type definition search" 197 | (Task.try (searchModule 15 16) >>= \result -> 198 | case result of 199 | Left message -> assertFailure (Text.unpack message) 200 | Right value -> 201 | case value of 202 | Search.Reference canonical name -> 203 | case N.toText name of 204 | "++" -> 205 | return () 206 | 207 | invalid -> 208 | ("Got a reference but it was \"" <> invalid <> "\" instead of \"String\"") 209 | |> Text.unpack 210 | |> assertFailure 211 | 212 | Search.Debug message -> 213 | assertFailure ("DEBUG: " ++ message) 214 | 215 | _ -> 216 | assertFailure "Expected reference" 217 | ) 218 | , testCase 219 | "Let definition type primitive search" 220 | (Task.try (searchModule 22 17) >>= \result -> 221 | case result of 222 | Left message -> assertFailure (Text.unpack message) 223 | Right value -> 224 | case value of 225 | Search.Type _ canType -> 226 | case Search.canTypeToText canType of 227 | "String" -> 228 | return () 229 | 230 | invalid -> 231 | ("Got a type but it was \"" <> invalid <> "\" instead of \"String\"") 232 | |> Text.unpack 233 | |> assertFailure 234 | 235 | Search.Debug message -> 236 | assertFailure ("DEBUG: " ++ message) 237 | 238 | _ -> 239 | assertFailure "Expected type primitive" 240 | ) 241 | , testCase 242 | "Let definition variable search" 243 | (Task.try (searchModule 22 26) >>= \result -> 244 | case result of 245 | Left message -> assertFailure (Text.unpack message) 246 | Right value -> 247 | case value of 248 | Search.Type _ canType -> 249 | case Search.canTypeToText canType of 250 | "String" -> 251 | return () 252 | 253 | invalid -> 254 | ("Got a type but it was \"" <> invalid <> "\" instead of \"String\"") 255 | |> Text.unpack 256 | |> assertFailure 257 | 258 | Search.Debug message -> 259 | assertFailure ("DEBUG: " ++ message) 260 | 261 | _ -> 262 | assertFailure "Expected Arg" 263 | ) 264 | ] 265 | 266 | 267 | hoverTests :: TestTree 268 | hoverTests = 269 | testGroup 270 | "Hover Tests" 271 | [ testCase 272 | "Top-level un-typed value def" 273 | (Task.try (hover 5 11) >>= \result -> 274 | case result of 275 | Left message -> assertFailure (Text.unpack message) 276 | Right value -> 277 | case value of 278 | Search.HoverType tipe -> 279 | case Search.canTypeToText tipe of 280 | "String" -> 281 | return () 282 | 283 | invalid -> 284 | ("Got a type but it was \"" <> invalid <> "\" instead of \"String\"") 285 | |> Text.unpack 286 | |> assertFailure 287 | 288 | Search.HoverDebug message -> 289 | assertFailure ("DEBUG: " ++ message) 290 | 291 | _ -> 292 | assertFailure "Expected type" 293 | ) 294 | , testCase 295 | "Top-level un-typed function def" 296 | (Task.try (hover 27 3) >>= \result -> 297 | case result of 298 | Left message -> assertFailure (Text.unpack message) 299 | Right value -> 300 | case value of 301 | Search.HoverType tipe -> 302 | case Search.canTypeToText tipe of 303 | "a -> String -> (a -> String) -> String" -> 304 | return () 305 | 306 | invalid -> 307 | ("Got a type but it was \"" <> invalid <> "\" instead of \"a -> String -> (a -> String) -> String\"") 308 | |> Text.unpack 309 | |> assertFailure 310 | 311 | Search.HoverDebug message -> 312 | assertFailure ("DEBUG: " ++ message) 313 | 314 | _ -> 315 | assertFailure "Expected type" 316 | ) 317 | , testCase 318 | "Top-level typed value def" 319 | (Task.try (hover 10 5) >>= \result -> 320 | case result of 321 | Left message -> assertFailure (Text.unpack message) 322 | Right value -> 323 | case value of 324 | Search.HoverType tipe -> 325 | case Search.canTypeToText tipe of 326 | "()" -> 327 | return () 328 | 329 | invalid -> 330 | ("Got a type but it was \"" <> invalid <> "\" instead of \"()\"") 331 | |> Text.unpack 332 | |> assertFailure 333 | 334 | Search.HoverDebug message -> 335 | assertFailure ("DEBUG: " ++ message) 336 | 337 | _ -> 338 | assertFailure "Expected type" 339 | ) 340 | , testCase 341 | "Top-level typed function def" 342 | (Task.try (hover 36 3) >>= \result -> 343 | case result of 344 | Left message -> assertFailure (Text.unpack message) 345 | Right value -> 346 | case value of 347 | Search.HoverType tipe -> 348 | case Search.canTypeToText tipe of 349 | "Custom -> ( String, Int ) -> Int" -> 350 | return () 351 | 352 | invalid -> 353 | ("Got a type but it was \"" <> invalid <> "\" instead of \"Custom -> ( String, Int ) -> Int\"") 354 | |> Text.unpack 355 | |> assertFailure 356 | 357 | Search.HoverDebug message -> 358 | assertFailure ("DEBUG: " ++ message) 359 | 360 | _ -> 361 | assertFailure "Expected type" 362 | ) 363 | , testCase 364 | "Top-level un-typed function def un-typed arg" 365 | (Task.try (hover 28 34) >>= \result -> 366 | case result of 367 | Left message -> assertFailure (Text.unpack message) 368 | Right value -> 369 | case value of 370 | Search.HoverType tipe -> 371 | case Search.canTypeToText tipe of 372 | "a" -> 373 | return () 374 | 375 | invalid -> 376 | ("Got a type but it was \"" <> invalid <> "\" instead of \"a\"") 377 | |> Text.unpack 378 | |> assertFailure 379 | 380 | Search.HoverDebug message -> 381 | assertFailure ("DEBUG: " ++ message) 382 | 383 | _ -> 384 | assertFailure "Expected type" 385 | ) 386 | , testCase 387 | "Top-level un-typed function def typed arg" 388 | (Task.try (hover 28 59) >>= \result -> 389 | case result of 390 | Left message -> assertFailure (Text.unpack message) 391 | Right value -> 392 | case value of 393 | Search.HoverType tipe -> 394 | case Search.canTypeToText tipe of 395 | "String" -> 396 | return () 397 | 398 | invalid -> 399 | ("Got a type but it was \"" <> invalid <> "\" instead of \"String\"") 400 | |> Text.unpack 401 | |> assertFailure 402 | 403 | Search.HoverDebug message -> 404 | assertFailure ("DEBUG: " ++ message) 405 | 406 | _ -> 407 | assertFailure "Expected type" 408 | ) 409 | , testCase 410 | "Top-level un-typed function def typed arg that is a function" 411 | (Task.try (hover 28 23) >>= \result -> 412 | case result of 413 | Left message -> assertFailure (Text.unpack message) 414 | Right value -> 415 | case value of 416 | Search.HoverType tipe -> 417 | case Search.canTypeToText tipe of 418 | "a -> String" -> 419 | return () 420 | 421 | invalid -> 422 | ("Got a type but it was \"" <> invalid <> "\" instead of \"a -> String\"") 423 | |> Text.unpack 424 | |> assertFailure 425 | 426 | Search.HoverDebug message -> 427 | assertFailure ("DEBUG: " ++ message) 428 | 429 | _ -> 430 | assertFailure "Expected type" 431 | ) 432 | , testCase 433 | "Top-level typed function def arg that is a bit nested" 434 | (Task.try (hover 22 27) >>= \result -> 435 | case result of 436 | Left message -> assertFailure (Text.unpack message) 437 | Right value -> 438 | case value of 439 | Search.HoverType tipe -> 440 | case Search.canTypeToText tipe of 441 | "String" -> 442 | return () 443 | 444 | invalid -> 445 | ("Got a type but it was \"" <> invalid <> "\" instead of \"String\"") 446 | |> Text.unpack 447 | |> assertFailure 448 | 449 | Search.HoverDebug message -> 450 | assertFailure ("DEBUG: " ++ message) 451 | 452 | _ -> 453 | assertFailure "Expected type" 454 | ) 455 | , testCase 456 | "Top-level typed function def custom type arg that is pattern matched" 457 | (Task.try (hover 36 16) >>= \result -> 458 | case result of 459 | Left message -> assertFailure (Text.unpack message) 460 | Right value -> 461 | case value of 462 | Search.HoverType tipe -> 463 | case Search.canTypeToText tipe of 464 | "String" -> 465 | return () 466 | 467 | invalid -> 468 | ("Got a type but it was \"" <> invalid <> "\" instead of \"String\"") 469 | |> Text.unpack 470 | |> assertFailure 471 | 472 | Search.HoverDebug message -> 473 | assertFailure ("DEBUG: " ++ message) 474 | 475 | _ -> 476 | assertFailure "Expected type" 477 | ) 478 | , testCase 479 | "Top-level typed function def custom type arg that is pattern matched reference" 480 | (Task.try (hover 37 20) >>= \result -> 481 | case result of 482 | Left message -> assertFailure (Text.unpack message) 483 | Right value -> 484 | case value of 485 | Search.HoverType tipe -> 486 | case Search.canTypeToText tipe of 487 | "String" -> 488 | return () 489 | 490 | invalid -> 491 | ("Got a type but it was \"" <> invalid <> "\" instead of \"String\"") 492 | |> Text.unpack 493 | |> assertFailure 494 | 495 | Search.HoverDebug message -> 496 | assertFailure ("DEBUG: " ++ message) 497 | 498 | _ -> 499 | assertFailure "Expected type" 500 | ) 501 | , testCase 502 | "Top-level typed function def tuple arg that is pattern matched" 503 | ( 504 | Task.try (hover 36 23) >>= \result -> 505 | case result of 506 | Left message -> assertFailure (Text.unpack message) 507 | Right value -> 508 | case value of 509 | Search.HoverType tipe -> 510 | case Search.canTypeToText tipe of 511 | "String" -> 512 | return () 513 | 514 | invalid -> 515 | ("Got a type but it was \"" <> invalid <> "\" instead of \"String\"") 516 | |> Text.unpack 517 | |> assertFailure 518 | 519 | Search.HoverDebug message -> 520 | assertFailure ("DEBUG: " ++ message) 521 | 522 | _ -> assertFailure "Expected type" 523 | ) 524 | , testCase 525 | "Top-level typed function def tuple arg that is pattern matched reference" 526 | ( 527 | Task.try (hover 36 29) >>= \result -> 528 | case result of 529 | Left message -> assertFailure (Text.unpack message) 530 | Right value -> 531 | case value of 532 | Search.HoverType tipe -> 533 | case Search.canTypeToText tipe of 534 | "String" -> 535 | return () 536 | 537 | invalid -> 538 | ("Got a type but it was \"" <> invalid <> "\" instead of \"String\"") 539 | |> Text.unpack 540 | |> assertFailure 541 | 542 | Search.HoverDebug message -> 543 | assertFailure ("DEBUG: " ++ message) 544 | 545 | _ -> assertFailure "Expected type" 546 | ) 547 | , testCase 548 | "Top-level typed function def tuple arg that is pattern matched" 549 | ( 550 | Task.try (hover 36 36) >>= \result -> 551 | case result of 552 | Left message -> assertFailure (Text.unpack message) 553 | Right value -> 554 | case value of 555 | Search.HoverType tipe -> 556 | case Search.canTypeToText tipe of 557 | "Int" -> 558 | return () 559 | 560 | invalid -> 561 | ("Got a type but it was \"" <> invalid <> "\" instead of \"Int\"") 562 | |> Text.unpack 563 | |> assertFailure 564 | 565 | Search.HoverDebug message -> 566 | assertFailure ("DEBUG: " ++ message) 567 | 568 | _ -> 569 | assertFailure "Expected type" 570 | ) 571 | , testCase 572 | "Top-level typed function def tuple arg that is pattern matched reference" 573 | ( 574 | Task.try (hover 37 43) >>= \result -> 575 | case result of 576 | Left message -> assertFailure (Text.unpack message) 577 | Right value -> 578 | case value of 579 | Search.HoverType tipe -> 580 | case Search.canTypeToText tipe of 581 | "Int" -> 582 | return () 583 | 584 | invalid -> 585 | ("Got a type but it was \"" <> invalid <> "\" instead of \"Int\"") 586 | |> Text.unpack 587 | |> assertFailure 588 | 589 | Search.HoverDebug message -> 590 | assertFailure ("DEBUG: " ++ message) 591 | 592 | _ -> assertFailure "Expected type" 593 | ) 594 | , testCase 595 | "let def custom type that is pattern matched" 596 | ( 597 | Task.try (hover 43 18) >>= \result -> 598 | case result of 599 | Left message -> assertFailure (Text.unpack message) 600 | Right value -> 601 | case value of 602 | Search.HoverType tipe -> 603 | case Search.canTypeToText tipe of 604 | "String" -> 605 | return () 606 | 607 | invalid -> 608 | ("Got a type but it was \"" <> invalid <> "\" instead of \"String\"") 609 | |> Text.unpack 610 | |> assertFailure 611 | 612 | Search.HoverDebug message -> 613 | assertFailure ("DEBUG: " ++ message) 614 | 615 | _ -> assertFailure "Expected type" 616 | ) 617 | ] 618 | -------------------------------------------------------------------------------- /test/sample/elm-stuff/.lsp/clone/elm.json: -------------------------------------------------------------------------------- 1 | { 2 | "type": "application", 3 | "source-directories": ["src"], 4 | "elm-version": "0.19.0", 5 | "dependencies": { 6 | "direct": { 7 | "elm/core": "1.0.2" 8 | }, 9 | "indirect": { 10 | "elm/json": "1.1.2" 11 | } 12 | }, 13 | "test-dependencies": { 14 | "direct": {}, 15 | "indirect": {} 16 | } 17 | } 18 | -------------------------------------------------------------------------------- /test/sample/elm-stuff/.lsp/clone/src/Main.elm: -------------------------------------------------------------------------------- 1 | module Main exposing (Custom(..), fifth, first, fourth, second, sixth, third) 2 | 3 | 4 | first = 5 | "hello, world" 6 | 7 | 8 | second : () 9 | second = 10 | () 11 | 12 | 13 | third : String -> Int -> String 14 | third arg1 arg2 = 15 | "appended" ++ arg1 16 | 17 | 18 | fourth : String -> String 19 | fourth arg = 20 | let 21 | appended = 22 | "apended" ++ arg 23 | in 24 | arg 25 | 26 | 27 | fifth thingToTransform thingToAppend strTransform = 28 | "appended" ++ strTransform thingToTransform ++ thingToAppend 29 | 30 | 31 | type Custom 32 | = Custom String 33 | 34 | 35 | sixth : Custom -> ( String, Int ) -> Int 36 | sixth (Custom str) ( anotherStr, anInt ) = 37 | String.length (str ++ anotherStr) * anInt 38 | 39 | 40 | seventh : Int -> Int 41 | seventh int = 42 | let 43 | (Custom str) = 44 | Custom "" 45 | in 46 | int * (String.length str) 47 | -------------------------------------------------------------------------------- /test/sample/elm-stuff/0.19.0/Main.elmi: -------------------------------------------------------------------------------- 1 | fifthaaelmcoreStringStringaelmcoreStringStringelmcoreStringStringfirstelmcoreStringStringfourthelmcoreStringStringelmcoreStringStringsecondsixthauthorprojectMainCustomelmcoreStringStringelmcoreBasicsIntelmcoreBasicsIntthirdelmcoreStringStringelmcoreBasicsIntelmcoreStringStringCustomCustomelmcoreStringString -------------------------------------------------------------------------------- /test/sample/elm-stuff/0.19.0/Main.elmo: -------------------------------------------------------------------------------- 1 | authorprojectMainCustomauthorprojectMainfifth thingToTransform thingToAppend strTransformelmcoreBasicsappendappendedelmcoreBasicsappend strTransformthingToTransform thingToAppendelmcoreBasicsappendauthorprojectMainfirst hello, worldauthorprojectMainfourth argappendedelmcoreBasicsappendapendedargargelmcoreBasicsappendauthorprojectMainsecondelmkernelUtils$authorprojectMainseventh int_n0authorprojectMainCustomstr_n0elmcoreBasicsmulintelmcoreStringlengthstrauthorprojectMainCustomelmcoreBasicsidentityelmcoreBasicsmulelmcoreStringlengthauthorprojectMainsixth _n0_n1str_n0 2 | anotherStr_n1anInt_n1elmcoreBasicsmulelmcoreStringlengthelmcoreBasicsappendstr 3 | anotherStranIntelmcoreBasicsappendelmcoreBasicsmulelmcoreStringlengthauthorprojectMainthird arg1arg2elmcoreBasicsappendappendedarg1elmcoreBasicsappend -------------------------------------------------------------------------------- /test/sample/elm.json: -------------------------------------------------------------------------------- 1 | { 2 | "type": "application", 3 | "source-directories": ["src"], 4 | "elm-version": "0.19.0", 5 | "dependencies": { 6 | "direct": { 7 | "elm/core": "1.0.2" 8 | }, 9 | "indirect": { 10 | "elm/json": "1.1.2" 11 | } 12 | }, 13 | "test-dependencies": { 14 | "direct": {}, 15 | "indirect": {} 16 | } 17 | } 18 | -------------------------------------------------------------------------------- /test/sample/src/Main.elm: -------------------------------------------------------------------------------- 1 | module Main exposing (Custom(..), fifth, first, fourth, second, sixth, third) 2 | 3 | 4 | first = 5 | "hello, world" 6 | 7 | 8 | second : () 9 | second = 10 | () 11 | 12 | 13 | third : String -> Int -> String 14 | third arg1 arg2 = 15 | "appended" ++ arg1 16 | 17 | 18 | fourth : String -> String 19 | fourth arg = 20 | let 21 | appended = 22 | "apended" ++ arg 23 | in 24 | arg 25 | 26 | 27 | fifth thingToTransform thingToAppend strTransform = 28 | "appended" ++ strTransform thingToTransform ++ thingToAppend 29 | 30 | 31 | type Custom 32 | = Custom String 33 | 34 | 35 | sixth : Custom -> ( String, Int ) -> Int 36 | sixth (Custom str) ( anotherStr, anInt ) = 37 | String.length (str ++ anotherStr) * anInt 38 | 39 | 40 | seventh : Int -> Int 41 | seventh int = 42 | let 43 | (Custom str) = 44 | Custom "" 45 | in 46 | int * (String.length str) 47 | --------------------------------------------------------------------------------